xmlconvert.in 26.7 KB
Newer Older
1
#!/usr/bin/perl -w
2
3
4

#
# EMULAB-COPYRIGHT
5
# Copyright (c) 2000-2006 University of Utah and the Flux Group.
6
7
8
9
10
# All rights reserved.
#

use English;
use Getopt::Std;
11
use XML::Parser;
12
13
#use RPC::XML;
#use RPC::XML::Parser;
14

15
16
17
18
#
# Convert between XML and DB representation of a virtual experiment.
# Very simple, no DTDs, DOMs, XSLs, etc. Just the facts ...
#
19
20
21
22
# XXX We do not regex the data carefully enough before inserting it into
# the DB. We run quotemeta() over it, but we should be more careful about
# per-slot checks.
#
23
24
sub usage()
{
25
    print STDOUT "Usage: xmlconvert [-x <xmlfile> [-n] [-p]] [-d] pid eid\n";
26
27
28
 
    exit(-1);
}
29
my $optlist  = "x:ndsp";
30
my $fromxml  = 0;
31
my $fromparser = 0;
32
my $impotent = 0;
33
my $debug    = 0;
34
35
36
# Results of parsing nse specifications. Therefore different treatment.
# In particular, we don't expect updates to the experiments table
my $simparse = 0;
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52

#
# Configure variables
#
my $TB       = "@prefix@";
my $TBOPS    = "@TBOPSEMAIL@";

# Locals
my $xmlfile;
my $pid;
my $eid;

# This goes at the beginning of the output.
my $XMLHEADER = "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>";

#
53
54
55
56
57
# These are the virtual tables that make up an experiment.  Each one
# could have multiple rows, each of which will be a hash table.
#
my %virtual_tables = 
    ("experiments"		=> { rows  => undef, 
58
59
60
				     tag   => "settings",
				     # Indicates a single row.
				     row   => undef,
61
62
63
				     attrs => [ ] },
     "virt_nodes"		=> { rows  => undef, 
				     tag   => "nodes",
64
				     row   => "node",
65
66
				     attrs => [ "vname" ]},
     "virt_lans"		=> { rows  => undef, 
67
68
69
70
				     tag   => "lan_members",
				     row   => "lan_member",
				     attrs => [ "vname" ]},
     "virt_lan_lans"		=> { rows  => undef, 
71
				     tag   => "lans",
72
				     row   => "lan",
73
74
75
				     attrs => [ "vname" ]},
     "virt_lan_settings"	=> { rows  => undef, 
				     tag   => "lan_settings",
76
				     row   => "lan_setting",
77
78
79
				     attrs => [ "vname", "capkey" ]},
     "virt_lan_member_settings" => { rows  => undef, 
				     tag   => "lan_member_settings",
80
				     row   => "lan_member_setting",
81
82
83
				     attrs => [ "vname", "member", "capkey" ]},
     "virt_trafgens"		=> { rows  => undef, 
				     tag   => "trafgens",
84
				     row   => "trafgen",
85
86
87
				     attrs => [ "vname", "vnode" ]},
     "virt_agents"		=> { rows  => undef, 
				     tag   => "agents",
88
				     row   => "agent",
89
90
91
				     attrs => [ "vname", "vnode" ]},
     "virt_node_desires"	=> { rows  => undef, 
				     tag   => "node_desires",
92
				     row   => "node_desire",
93
				     attrs => [ "vname", "desire" ]},
Timothy Stack's avatar
   
Timothy Stack committed
94
95
96
97
     "virt_node_startloc"	=> { rows  => undef, 
				     tag   => "node_startlocs",
				     row   => "node_startloc",
				     attrs => [ "vname", "building" ]},
98
99
     "virt_routes"		=> { rows  => undef, 
				     tag   => "routes",
100
				     row   => "route",
101
102
103
				     attrs => [ "vname", "src", "dst" ]},
     "virt_vtypes"		=> { rows  => undef, 
				     tag   => "vtypes",
104
				     row   => "vtype",
105
106
107
				     attrs => [ "name" ]},
     "virt_programs"		=> { rows  => undef, 
				     tag   => "programs",
108
				     row   => "program",
109
				     attrs => [ "vname", "vnode" ]},
Timothy Stack's avatar
   
Timothy Stack committed
110
111
112
113
     "virt_user_environment"	=> { rows  => undef, 
				     tag   => "user_environments",
				     row   => "user_environment",
				     attrs => [ "name", "value" ]},
114
115
     "nseconfigs"		=> { rows  => undef, 
				     tag   => "nseconfigs",
116
				     row   => "nseconfig",
117
118
119
				     attrs => [ "vname" ]},
     "eventlist"		=> { rows  => undef, 
				     tag   => "events",
120
				     row   => "event",
Leigh B. Stoller's avatar
Leigh B. Stoller committed
121
122
123
124
				     attrs => [ "vname" ]},
     "event_groups"		=> { rows  => undef, 
				     tag   => "event_groups",
				     row   => "event_group",
125
				     attrs => [ "group_name", "agent-name" ]},
126
127
128
     "virt_firewalls"		=> { rows  => undef, 
				     tag   => "virt_firewalls",
				     row   => "virt_firewall",
129
130
131
132
				     attrs => [ "fwname", "type", "style" ]},
     "firewall_rules"		=> { rows  => undef, 
				     tag   => "firewall_rules",
				     row   => "firewall_rule",
Timothy Stack's avatar
   
Timothy Stack committed
133
134
135
136
				     attrs => [ "fwname", "ruleno", "rule" ]},
     "virt_tiptunnels"		=> { rows  => undef, 
				     tag   => "tiptunnels",
				     row   => "tiptunnel",
137
				     attrs => [ "host", "vnode" ]},
138
139
140
141
     "virt_parameters"           => { rows  => undef, 
				      tag   => "parameters",
				      row   => "parameter",
				      attrs => [ "name", "value" ]},
142
143
144
145
146
     # This is a fake table. See below. If we add more, lets generalize.
     "external_sourcefiles"	=> { rows  => undef, 
				     tag   => "nsfiles",
				     row   => "nsfiles",
				     attrs => [ "pathname" ]}
147
     );
148
149
150
151

# XXX
# The experiment table is special. Only certain fields are allowed to
# be updated. Not sure what the right approach for this is.
152
# Note that I regex the data before inserting it below.
153
#
154
155
156
157
158
159
160
my %experiment_fields = ("multiplex_factor"		=> 1,
			 "forcelinkdelays"		=> 1,
			 "uselinkdelays"		=> 1,
			 "usewatunnels"			=> 1,
			 "uselatestwadata"		=> 1,
			 "wa_delay_solverweight"	=> 1,
			 "wa_bw_solverweight"		=> 1,
161
			 "wa_plr_solverweight"		=> 1,
162
163
			 "cpu_usage"			=> 1,
			 "mem_usage"			=> 1,
164
			 "allowfixnode"			=> 1,
165
			 "veth_encapsulate"		=> 1,
166
167
			 "jail_osname"			=> 1,
			 "delay_osname"			=> 1,
168
169
			 "sync_server"			=> 1,
		         "use_ipassign"			=> 1,
170
171
172
		         "ipassign_args"		=> 1,
		         "usemodelnet"			=> 1,
		         "modelnet_cores"		=> 1,
173
		         "modelnet_edges"		=> 1,
174
		         "elab_in_elab"			=> 1,
175
		         "elabinelab_eid"		=> 1,
176
		         "elabinelab_cvstag"		=> 1,
177
178
		         "security_level"		=> 1,
		         "delay_capacity"		=> 1);
179

180
181
182
183
184
185
186
187
# New parsing code state machine control.
my $PARSING_NOTYET	= 0;
my $PARSING_EXPERIMENT	= 1;
my $PARSING_TABLE	= 2;
my $PARSING_ROW		= 3;
my $PARSING_SLOT	= 4;
my $parserstate		= $PARSING_NOTYET;

188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
#
# Turn off line buffering on output
#
$| = 1;

#
# Untaint the path
# 
$ENV{'PATH'} = "/bin:/usr/bin:/sbin:/usr/sbin";
delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};

#
# Testbed Support libraries
#
use lib "@prefix@/lib";
use libdb;
use libtestbed;
205
use libArchive;
206

207
208
sub fatal($);

209
210
211
212
213
214
215
216
217
218
219
#
# Parse command arguments. Once we return from getopts, all that should
# left are the required arguments.
#
%options = ();
if (! getopts($optlist, \%options)) {
    usage();
}
if (defined($options{"d"})) {
    $debug = 1;
}
220
221
222
if (defined($options{"p"})) {
    $fromparser = 1;
}
223
224
225
if (defined($options{"s"})) {
    $simparse = 1;
}
226
227
228
229
230
231
232
233
234
235
236
if (defined($options{"x"})) {
    $fromxml = 1;
    $xmlfile = $options{"x"};

    if ($xmlfile =~ /^([-\w\/\.]+)$/) {
	$xmlfile = $1;
    }
    else {
	fatal("Bad data in argument: $xmlfile.");
    }
    if (defined($options{"n"})) {
237
	$impotent = 1;
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
    }    
}
if (@ARGV != 2) {
    usage();
}
$pid   = $ARGV[0];
$eid   = $ARGV[1];

# Taint Check.
if ($pid =~ /^([-\w]+)$/) {
    $pid = $1;
}
else {
    fatal("Bad data in argument: $pid.");
}
if ($eid =~ /^([-\w]+)$/) {
    $eid = $1;
}
else {
    fatal("Bad data in argument: $eid.");
}

260
261
262
263
264
265
my %event_objtypes;
my $query_result = DBQueryFatal("select idx,type from event_objecttypes");
while (my ($idx,$type) = $query_result->fetchrow_array()) {
    $event_objtypes{$type} = $idx;
}

266
# Do it
267
268
269
270

sub readXML($$$$);
sub writeXML_XML($$);

271
if ($fromxml) {
272
    readXML($pid, $eid, $xmlfile, $fromparser);
273
274
}
else {
275
    writeXML_XML($pid, $eid);
276
277
278
279
280
281
282
283
}
exit(0);

#
# Read in XML and convert to DB representation, doing lots of checks!
# This code is silly. Overly stylized (one tag per line!). Should
# use the XML::Parser package instead. But this was easy and fun for a
# first cut. 
284
285
286
287
288
289
290
291
#
# State variables for parsing code below.
my $current_expt;
my $current_table;
my $current_row;
my $current_slot;
my $current_data;

292
293
sub readXML($$$$) {
    my ($pid, $eid, $xmlfile, $fromparser) = @_;
294
295
296
297
298
299
300
    my %experiment;

    if ($xmlfile ne "-") {
	open(STDIN, "< $xmlfile")
	    or fatal("opening $xmlfile for STDIN: $!");
    }

301
    if ($fromparser) {
302
303
304
305
306
307
308
309
310
311
312
313
	my $line = <STDIN>;
	
	# Scan for the beginning marker or EOF.
	while ($line && ($line ne "#### BEGIN XML ####\n")) {
	    print "$line"; # Print it out for the user.
	    $line = <STDIN>;
	}
	
	if (!$line) {
	    fatal("NS script never reached \"\$ns run\"");
	}
	
314
315
316
317
	#
	# Create a parser.
	#
	my $parser = new XML::Parser(Style => 'Tree');
318
319
	$parser->setHandlers('Start'   => \&StartElement_FromParser,
			     'End'     => \&EndElement_FromParser,
320
321
322
323
324
325
326
			     'Char'    => \&ProcessElement);

	fatal($@)
	    if (eval { $parser->parse(*STDIN); return 1; } != 1);
    }
    else {
	#
327
	# Create a parser.
328
	#
329
330
331
332
	my $parser = new XML::Parser(Style => 'Tree');
	$parser->setHandlers('Start'   => \&StartElement,
			     'End'     => \&EndElement,
			     'Char'    => \&ProcessElement);
333

334
335
	fatal($@)
	    if (eval { $parser->parse(*STDIN); return 1; } != 1);
336
    }
337
338
339
340
341
342
343
344
345
346
347
348
349

    # If these are the results of parsing the nse specifications,
    # we don't expect updates to the experiments table
    my %experiments_table;
    if ( ! $simparse ) {

	#
	# Verify. 
	#
	# Must be exactly one experiments table row, and we prune out lots
	# of stuff that is not allowed. Note that we never insert a
	# experiment, but only allow updates of certain values. 
	#
350
	if (scalar(@{ $virtual_tables{"experiments"}->{"rows"} }) != 1) {
351
352
	    fatal("Must be exactly one experiments table row!");
	}
353
	%experiments_table = %{@{$virtual_tables{"experiments"}->{"rows"}}[0]};
354
355
356
357
	foreach my $key (keys(%experiments_table)) {
	    delete($experiments_table{$key})
		if (!exists($experiment_fields{$key}));
	}
358
359
360
361
362
363
364
365
    }

    #
    # Okay, a hokey DoS check. Do not allow more than 10000 total rows!
    # Why so many? Well, Rob likes to generate lots of events!
    #
    my $count = 0;
    foreach my $table (keys(%virtual_tables)) {
366
367
	$count += scalar(@{$virtual_tables{$table}->{"rows"}})
	    if (defined($virtual_tables{$table}->{"rows"}));
368
    }
369
    if ($count > 100000) {
370
371
372
373
374
	fatal("Too many rows of data!");
    }

    #
    # Okay, thats all the checking we do! There is not much that can
375
376
    # screw up the DB just by inserting rows into the allowed set of
    # virtual experiment tables, since we ignore the pid/eid in the xml. 
377
    #
378
379
    # First the experiments table, which gets an update statement, if there
    # is anything to update.
380
    #
381
    if ( (! $simparse) && scalar(keys(%experiments_table))) {
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
	my @setlist  = ();

	my $describe_result =
	    DBQueryFatal("describe experiments");

	#
	# Need to find the default values for slots that are not sent to
	# us in the xml so that we can set them properly.
	#
	while (my $rowref = $describe_result->fetchrow_hashref()) {
	    my $slot  = $rowref->{"Field"};
	    my $value = $rowref->{"Default"};

	    if (exists($experiment_fields{$slot}) &&
		! exists($experiments_table{$slot})) {
		$experiments_table{$slot} =
		    (defined($value) ? $value : "NULL");
	    }
	}
401

402
403
	foreach my $key (keys(%experiments_table)) {
	    my $val = $experiments_table{$key};
404

405
	    if (!defined($val) || $val eq "NULL" || $val eq "") {
406
407
408
		push(@setlist, "$key=NULL");
	    }
	    else {
409
410
		# Sanity check the fields.
		if (TBcheck_dbslot($val, "experiments", $key,
411
			TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)) {
412
413
414
		    $val = DBQuoteSpecial($val);
		    
		    push(@setlist, "$key=$val");
415
416
		}
		else {
417
418
		    fatal("Illegal characters in table data: ".
			  "experiments:$key - $val");
419
		}
420
	    }	    
421
	}
422
423
424
425
426
427
428
429
	my $query = "update experiments ".
	            "set " . join(",", @setlist) . " " .
		    "where eid='$eid' and pid='$pid'";

	print "$query\n"
	    if ($debug);
	DBQueryFatal($query)
	    if (!$impotent);
430
431
432
433
434
435
436
    }

    #
    # Now all the other tables, which get inserts. Need to delete all the
    # old info too.
    #
    foreach my $table (keys(%virtual_tables)) {
437
438
439
440
	# Don't want to muck with this table! Done above. 
	next
	    if ($table eq "experiments");

441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
	#
	# The external_sourcefiles table is treated special. Might
	# become a real table later, once we decide if its useful.
	# 
	if ($table eq "external_sourcefiles") {
	    foreach my $rowref (@{$virtual_tables{$table}->{"rows"}}) {
		my %rowhash = %{ $rowref };

		# If no actual rows, then skip. Might happen.
		last
		    if (! scalar(keys(%rowhash)));

		if (exists($rowhash{'pathname'}) &&
		    defined($rowhash{'pathname'})) {
		    my $pathname = $rowhash{'pathname'};

		    # libArchive checks the paths to make sure they are
		    # from the allowed places.
		    if (libArchive::TBExperimentArchiveAddFile($pid, $eid,
							       $pathname)
			< 0) {
			fatal("Failed to add $pathname to the archive!");
		    }
		}
	    }
	    next;
	}

469
470
471
472
473
474
	# Delete only during the initial parsing and not
	# during parsing of nse specifications
	if ( ! $simparse ) {
	    DBQueryFatal("delete from $table ".
			 "where eid='$eid' and pid='$pid'")
		if (!$impotent);
475
476
477
478
479
480
481
482
483
484
485
486
	} else {
	    # The nseconfigs table is special. During a
	    # simparse, we need delete all rows for the
	    # experiment except the one with the vname
	    # 'fullsim'. This row is essentially virtual
	    # info and does not change across swapins
	    # where as the other rows depend on the
	    # mapping
	    if ( !$impotent && ($table eq "nseconfigs") ) {
		DBQueryFatal("delete from $table ". 
		             "where eid='$eid' and pid='$pid' and ".
			     "vname!='fullsim'")
487
488
489
490
491
492
493
494
495
496
	    } elsif ( !$impotent && (($table eq "eventlist") ||
				       ($table eq "virt_agents")) ) {
	        # Both eventlist and virt_agents need to be cleared
		# for NSE event objecttype since entries in this
		# table depend on the particular mapping
		my $nse_objtype = $event_objtypes{"NSE"};
		DBQueryFatal("delete from $table ". 
		             "where pid='$pid' and eid='$eid' and ".
			     "objecttype='$nse_objtype'");
	    } 
497
	}
498
	next
499
	    if (!defined($virtual_tables{$table}->{"rows"}));
500

501
	foreach my $rowref (@{$virtual_tables{$table}->{"rows"}}) {
502
503
504
505
	    my %rowhash = %{ $rowref };
	    my @fields  = ("pid", "eid");
	    my @values  = ("'$pid'", "'$eid'");

506
507
508
509
	    # If no actual rows, then skip. Might happen.
	    last
		if (! scalar(keys(%rowhash)));

510
	    foreach my $key (keys(%rowhash)) {
511
		my $val = $rowhash{$key};
512

513
		if (!defined($val) || $val eq "NULL") {
514
515
		    push(@values, "NULL");
		}
516
517
518
		elsif ($val eq "") {
		    push(@values, "''");
		}
519
		else {
520
521
522
523
524
525
526
527
528
529
		    # Sanity check the fields.
		    if (TBcheck_dbslot($val, $table, $key,
				 TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)) {
			push(@values, DBQuoteSpecial($val));
		    }
		    else {
			fatal("Illegal characters in table data: ".
			      "$table:$key - $val");
		    }
		}
530
531
		push(@fields, $key);
	    }
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
	    # If we are called after an nseparse, we need to
	    # use replace coz some of the tables such as 
	    # virt_agents and eventlist are not truly
	    # virtual tables. That is coz they contain the
	    # vnode field which is the same as the vname
	    # field in the reserved table. For simulated
	    # nodes, the mapping may change across swapins
	    # and the event may have to be delivered to a
	    # different simhost
	    if ( $simparse ) {
		$query = "replace into $table (" . join(",", @fields) . ") ".
		"values (" . join(",", @values) . ") ";
	    } else {
		$query = "insert into $table (" . join(",", @fields) . ") ".
		"values (" . join(",", @values) . ") ";
	    }
548
549
550
551

	    print "$query\n"
		if ($debug);
	    DBQueryFatal($query)
552
		if (!$impotent);
553
554
555
556
557
	}
    }
    return 0;
}

558
559
560
561
562
563
#
# XML::Parser routines.
#
#
# Start an element.
# 
564
sub StartElement_FromParser ($$$)
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
{
    my ($expat, $element, %attrs) = @_;

    if ($element eq "virtual_experiment") {
	fatal("Out of sync at experiment start: $element")
	    if (defined($current_expt) ||
		defined($current_table) ||
		defined($current_row) ||
		defined($current_slot));
	$current_expt = "$pid/$eid";
	
	#
	# Sanity check pid/eid.
	#
	if ((exists($attrs{'pid'}) && $attrs{'pid'} ne $pid) ||
	    (exists($attrs{'eid'}) && $attrs{'eid'} ne $eid)) {
	    fatal("pid/eid mismatch!");
	}
    }
    elsif (exists($virtual_tables{$element})) {
	#
	# A new table start.
	#
	fatal("Out of sync at element start: $element")
	    if (!defined($current_expt) ||
		defined($current_table) ||
		defined($current_row) ||
		defined($current_slot));
	$current_table = $element;

595
596
	if (! defined($virtual_tables{$element}->{"rows"})) {
	    $virtual_tables{$element}->{"rows"} = [];
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
	}
	print "Starting new table: $element\n"
	    if ($debug);
    }
    elsif ($element eq "row") {
	fatal("Out of sync at row start: $element")
	    if (!defined($current_expt) ||
		!defined($current_table) ||
		defined($current_row) ||
		defined($current_slot));
	$current_row = {};
    }
    else {
	fatal("Out of sync at slot start: $element")
	    if (!defined($current_expt) ||
		!defined($current_table) ||
		!defined($current_row) ||
		defined($current_slot));
	$current_slot = $element;
	$current_data = "";
    }
}

#
# End an element.
# 
623
sub EndElement_FromParser ($$)
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
{
    my ($expat, $element) = @_;

    if ($element eq "virtual_experiment") {
	fatal("Out of sync at experiment start: $element")
	    if (!defined($current_expt) ||
		defined($current_table) ||
		defined($current_row) ||
		defined($current_slot));
	undef($current_expt);
    }
    elsif (exists($virtual_tables{$element})) {
	#
	# A table termination.
	#
	fatal("Out of sync at element end: $element")
	    if (!defined($current_expt) ||
		!defined($current_table) ||
		defined($current_row) ||
		defined($current_slot));
	undef($current_table);
    }
    elsif ($element eq "row") {
	fatal("Out of sync at row end: $element")
	    if (!defined($current_expt) ||
		!defined($current_table) ||
		!defined($current_row) ||
		defined($current_slot));

	print "Adding new row to table $current_table\n"
	    if ($debug);
	
656
	push(@{ $virtual_tables{$current_table}->{"rows"} }, $current_row);
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
	undef($current_row);
    }
    else {
	fatal("Out of sync at slot end: $element")
	    if (!defined($current_expt) ||
		!defined($current_table) ||
		!defined($current_row) ||
		!defined($current_slot));
    
	#
	# Always ignore pid/eid.
	#
	if ($current_slot ne "pid" && $current_slot ne "eid") {
	    print "    Entering new slot: $current_slot: $current_data\n"
		if ($debug);
	    $current_row->{$current_slot} = $current_data;
	}
	undef($current_slot);
	undef($current_data);
    }
}

#
# Process stuff inside a slot.
# 
sub ProcessElement ($$)
{
    my ($expat, $string) = @_;

    if (defined($current_slot)) {
	$current_data .= xmldecode($string);
    }
}

691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
#
# Start an element.
#
sub StartElement ($$$)
{
    my ($expat, $element, %attrs) = @_;

    #
    # First element must be the experiment tag; It starts the process.
    #
    if ($parserstate == $PARSING_NOTYET) {
	fatal("Must start with an experiment tag!")
	    if ($element ne "experiment");

	fatal("Out of sync at experiment start: $element")
	    if (defined($current_expt) ||
		defined($current_table) ||
		defined($current_row) ||
		defined($current_slot));
	$current_expt = "$pid/$eid";
	
	#
	# Sanity check pid/eid.
	#
	if ((exists($attrs{'pid'}) && $attrs{'pid'} ne $pid) ||
	    (exists($attrs{'eid'}) && $attrs{'eid'} ne $eid)) {
	    fatal("pid/eid mismatch!");
	}
	print "Starting new experiment $pid/$eid\n"
	    if ($debug);
	
	$parserstate = $PARSING_EXPERIMENT;
    }
    elsif ($parserstate == $PARSING_EXPERIMENT) {
	#
	# Need to find the right table.
	#
	my $table;
	
	foreach my $key (keys(%virtual_tables)) {
	    if ($virtual_tables{$key}->{"tag"} eq $element) {
		$table = $key;
		last;
	    }
	}
	fatal("Unknown table: $element")
	    if (!defined($table));

	fatal("Out of sync at table start: $element")
	    if (!defined($current_expt) ||
		defined($current_table) ||
		defined($current_row) ||
		defined($current_slot));
	
	if (! defined($virtual_tables{$table}->{"rows"})) {
	    $virtual_tables{$table}->{"rows"} = [];
	}
	$current_table = $table;
	$parserstate   = $PARSING_TABLE;

	print "Starting new table: $table\n"
	    if ($debug);

	# Skip to parsing a row.
	if (!defined($virtual_tables{$current_table}->{"row"})) {
	    $current_row = {};
	    $parserstate = $PARSING_ROW;
	}
    }
    elsif ($parserstate == $PARSING_TABLE) {
	#
	# A row in a table. row tag must match table tag.
	#
	fatal("Out of sync at row start: $element")
	    if ((!defined($current_expt) ||
		 !defined($current_table) ||
		 defined($current_row) ||
		 defined($current_slot)) ||
		$virtual_tables{$current_table}->{"row"} ne $element);

	print "Starting new row at $element in table: $current_table\n"
	    if ($debug);
	
	$current_row = {};
	$parserstate = $PARSING_ROW;
    }
    elsif ($parserstate == $PARSING_ROW) {
	#
	# A slot in a row.
	# 
	fatal("Out of sync at slot start: $element")
	    if (!defined($current_expt) ||
		!defined($current_table) ||
		!defined($current_row) ||
		defined($current_slot));

	print "Starting new slot $element in table: $current_table\n"
	    if ($debug);
	
	$parserstate  = $PARSING_SLOT;
	$current_slot = $element;
	$current_data = "";
    }
    else {
	fatal("Out of sync at element: $element");
    }
}

#
# End an element.
# 
sub EndElement ($$)
{
    my ($expat, $element) = @_;

    if ($parserstate == $PARSING_EXPERIMENT) {
	fatal("Out of sync at experiment start: $element")
	    if ($element ne "experiment" ||
		(!defined($current_expt) ||
		 defined($current_table) ||
		 defined($current_row) ||
		 defined($current_slot)));
	undef($current_expt);
	$parserstate = $PARSING_NOTYET;
    }
    elsif ($parserstate == $PARSING_TABLE) {
	#
	# A table termination.
	#
	fatal("Out of sync at element end: $element")
	    if ((!defined($current_expt) ||
		 !defined($current_table) ||
		 defined($current_row) ||
		 defined($current_slot)) ||
		$element ne $virtual_tables{$current_table}->{"tag"});
	undef($current_table);
	$parserstate = $PARSING_EXPERIMENT;
    }
    elsif ($parserstate == $PARSING_ROW) {
	#
	# A row termination.
	# 
	fatal("Out of sync at row end: $element")
	    if ((!defined($current_expt) ||
		 !defined($current_table) ||
		 !defined($current_row) ||
		 defined($current_slot)) ||
		(defined($virtual_tables{$current_table}->{"row"}) &&
		 $element ne $virtual_tables{$current_table}->{"row"}));
		
	print "Adding new row $element to table $current_table\n"
	    if ($debug);
	
	push(@{ $virtual_tables{$current_table}->{"rows"} }, $current_row);
	undef($current_row);
	$parserstate = $PARSING_TABLE;

	# Skip to parsing an experiment
	if (!defined($virtual_tables{$current_table}->{"row"})) {
	    undef($current_table);
	    $parserstate = $PARSING_EXPERIMENT;
	}
    }
    elsif ($parserstate == $PARSING_SLOT) {
	#
	# A slot termination.
	# 
	fatal("Out of sync at slot end: $element")
	    if (!defined($current_expt) ||
		!defined($current_table) ||
		!defined($current_row) ||
		!defined($current_slot));
    
	#
	# Always ignore pid/eid.
	#
	if ($current_slot ne "pid" && $current_slot ne "eid") {
	    print "    Entering new slot: $current_slot: $current_data\n"
		if ($debug);
	    $current_row->{$current_slot} =
		($current_data ne "__NULL__" ? $current_data : undef);
	}
	undef($current_slot);
	undef($current_data);
	$parserstate = $PARSING_ROW;
    }
}

879
880
881
882
#
# Convert a virtual experiment representation into XML and spit it out.
# The DB holds the data of course.
#
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
sub writeXML_XML($$) {
    my ($pid, $eid) = @_;

    my $query_result =
	DBQueryFatal("select * from experiments ".
		     "where eid='$eid' and pid='$pid'");

    if (! $query_result->numrows) {
	fatal("No such experiment $pid/$eid exists!");
    }

    spitxml_header();
    spitxml_opentag("experiment pid='$pid' eid='$eid'", 0);
    spitxml_opentag("settings", 1);
    spitxml_spaces(2);
    
    my $settings = $query_result->fetchrow_hashref();

    foreach my $key (keys(%{ $settings })) {
	my $data = $settings->{$key};
	
	spitxml_entity($key, $data, 0);
    }
    spitxml_closetag("settings", 1);

    #
    # Read in a set of tables that live at top level.
    # 
    foreach my $table (keys(%virtual_tables)) {
	next
	    if ($table eq "experiments");
	
	my $tabletag = $virtual_tables{$table}->{"tag"};
	my $rowtag   = $virtual_tables{$table}->{"row"};

	$query_result =
	    DBQueryFatal("select * from $table ".
			 "where eid='$eid' and pid='$pid'");

	next
	    if (! $query_result->numrows);

	spitxml_opentag($tabletag, 1);
	
	while (my $rowref = $query_result->fetchrow_hashref()) {
	    spitxml_opentag($rowtag, 2);
	    spitxml_spaces(3);

	    foreach my $key (keys(%{ $rowref })) {
		my $data = $rowref->{$key};

		next
		    if ($key eq "pid" || $key eq "eid");

		spitxml_entity($key, $data, 0);
	    }
	    print "\n";
	    spitxml_closetag($rowtag, 2);
	}
	spitxml_closetag($tabletag, 1);
    }

    spitxml_closetag("experiment", 0);
    return 0;
}

#
# This is the old version; I will eventually remove it. 
#
sub writeXML_RPC($$) {
953
954
955
956
957
958
959
960
961
    my ($pid, $eid) = @_;

    my $query_result =
	DBQueryFatal("select * from experiments ".
		     "where eid='$eid' and pid='$pid'");

    if (! $query_result->numrows) {
	fatal("No such experiment $pid/$eid exists!");
    }
962
963
    my $exp = {};
    $exp->{"experiment"}->{"settings"} = $query_result->fetchrow_hashref();
964

965
966
967
    foreach my $key (keys(%{ $exp->{"experiment"}->{"settings"} })) {
	$exp->{"experiment"}->{"settings"}->{$key} = ""
	    if (!defined($exp->{"experiment"}->{"settings"}->{$key}));
968
969
    }

970
971
972
973
974
975
976
977
    #
    # Read in a set of tables that live at top level.
    # 
    foreach my $table (keys(%virtual_tables)) {
	next
	    if ($table eq "experiments");
	
	my $tag = $virtual_tables{$table}{"tag"};
978

979
980
981
982
983
984
985
986
987
988
989
990
991
992
	if (!exists($exp->{"experiment"}->{$tag})) {
	    $exp->{"experiment"}->{$tag} = [];
	}
	$query_result =
	    DBQueryFatal("select * from $table ".
			 "where eid='$eid' and pid='$pid'");

	while (my $rowref = $query_result->fetchrow_hashref()) {
	    foreach my $key (keys(%{ $rowref })) {
		$rowref->{$key} = ""
		    if (!defined($rowref->{$key}));
	    }
	    push(@{ $exp->{"experiment"}->{$tag} }, $rowref);
	}
993
994
    }

995
996
    my $foo = new RPC::XML::response($exp);
    print $foo->as_string();
997
    
998
    return 0;
999
1000
}

1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
#
# Utility functions to pretty print XML output, with specified indentation.
#
sub spitxml_spaces($)
{
    my ($level) = @_;

    my $spaces = $level * 1;

    printf("%${spaces}s", "");
}
    
sub spitxml_opentag($$)
{
    my ($tag, $level) = @_;

    spitxml_spaces($level);
    print "<${tag}>\n";
}

sub spitxml_closetag($$)
{
    my ($tag, $level) = @_;

    spitxml_spaces($level);
    print "</${tag}>\n";
}

sub spitxml_header()
{
    print "$XMLHEADER\n";
}

sub spitxml_entity($$$)
{
    my ($tag, $data, $level) = @_;

    $data = "__NULL__"
	if (!defined($data));

    spitxml_spaces($level)
	if ($level);

    if ($data eq "") {
	print "<${tag}/>";
    }
    else {
	print "<${tag}>" . xmlencode($data) . "</${tag}>";
    }
}

1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
#
# Convert from/to XML special chars. Not many of them ...
# 
sub xmlencode($)
{
    my ($string) = @_;

    my %specialchars = ('&' => '&amp;',
			'<' => '&lt;',
			'>' => '&gt;',
1062
1063
1064
			"'" => '&#39;',
			"]" => '&#93;',
			'"' => '&#34;');
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076

    $string =~ s/([&<>"'])/$specialchars{$1}/ge;
    return $string;
}

sub xmldecode($)
{
    my ($string) = @_;

    my %specialchars = ('&amp;'  => '&',
			'&lt;'   => '<',
			'&gt;'   => '>',
1077
1078
1079
			'&#39;'  => "'",
			'&#93;'  => ']',
			'&#34;'  => '"');
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092

    $string =~ s/(&\w+;)/$specialchars{$1}/ge;
    return $string;
}

# Die
sub fatal($)
{
    my ($msg) = @_;

    die("*** $0:\n".
	"    $msg\n");
}