File Coverage

blib/lib/DMTF/CIM/MOF.pm

Criterion	Covered	Total	%
statement	21	898	2.3
branch	0	578	0.0
condition	0	60	0.0
subroutine	7	14	50.0
pod	1	7	14.2
total	29	1557	1.8

package DMTF::CIM::MOF;

use warnings;
use strict;
use Storable;
use DMTF::CIM;
use Carp;
use version;
our $VERSION = qv('0.05');
use Exporter qw ( import );


# Module implementation here
sub valid_MOF_integer
{
	my $value=shift;
	# Binary
	if($value =~ /^[-+]?1[01]*[bB]$/) {
		return 2;
	}
	# Octal
	elsif($value =~ /^[-+]?0[0-7]*$/) {
		return 8;
	}
	# Decimal
	elsif($value =~ /^[-+]?[1-9][0-9]*$/) {
		return 10;
	}
	# Hex
	elsif($value =~ /^[-+]?0[Xx][0-9a-fA-F]*$/) {
		return 16;
	}
	# Unknown
	elsif($value =~ /^[-+]?$/) {
		return 1;
	}
	return 0;
}

sub parse_MOF_integer
{
	my $value=shift;

	# Decimal
	if($value =~ /^[-+]?[1-9][0-9]*$/) {
		$value += 0;
	}
	else {
		# Binary
		if($value =~ /^([-+]?)(1[01]*)[bB]$/) {
			$value = "0b$2";
		}
		# Octal
		elsif($value =~ /^([-+]?)(0[0-7]*)$/) {
			$value = $2;
		}
		elsif($value =~ /^([-+]?)(0[Xx][0-9a-fA-F]*)$/) {
			$value=$2;
		}
		$value=oct($value);
		$value=0-$value if($1 eq '-');
	}
	return $value;
}

sub setdefaults
{
	my $scope=shift;
	my $qualifier=shift;

	foreach my $key (keys %$scope) {
		if(!defined $scope->{$key}{qualifiers}{lc($qualifier->{name})}) {
			$scope->{$key}{qualifiers}{lc($qualifier->{name})} = {type=>$qualifier->{type}};
			if(defined $qualifier->{array}) {
				$scope->{$key}{qualifiers}{lc($qualifier->{name})}{array}=$qualifier->{array};
			}
		}
		if(defined $qualifier->{value}) {
			if(ref($qualifier->{value}) eq '') {
				$scope->{$key}{qualifiers}{lc($qualifier->{name})}{value}=$qualifier->{value};
			}
			else {
				$scope->{$key}{qualifiers}{lc($qualifier->{name})}{value}=Storable::dclone($qualifier->{value});
			}
		}
	}
}

sub derive
{
	my $target=shift;
	my $super=shift;
	my $qualifiers=shift;

	# First, Deal with qualifiers...
	my $targetscope;
	if(defined $target->{qualifiers}{association} && $target->{qualifiers}{association}{value} eq 'true') {
		$targetscope='association';
	}
	elsif(defined $target->{qualifiers}{indication} && $target->{qualifiers}{indication}{value} eq 'true') {
		$targetscope='indication';
	}
	else {
		$targetscope='class';
	}
	foreach my $qualifier (keys %$qualifiers) {
		if(defined $qualifiers->{$qualifier}{scope}{$targetscope} || defined $qualifiers->{$qualifier}{scope}{all}) {
			if(!defined $target->{qualifiers}{$qualifier}) {
				$target->{qualifiers}{$qualifier} = {type=>$qualifiers->{$qualifier}{type}};
				if(defined $qualifiers->{$qualifier}{array}) {
					$target->{qualifiers}{$qualifier}{array}=$qualifiers->{$qualifier}{array};
				}
			}
			if(!defined $target->{qualifiers}{$qualifier}{value}) {
				if(defined $super->{qualifiers}{$qualifier}{value}) {
					if(ref($super->{qualifiers}{$qualifier}{value}) eq '') {
						$target->{qualifiers}{$qualifier}{value}=$super->{qualifiers}{$qualifier}{value};
					}
					else {
						$target->{qualifiers}{$qualifier}{value}=Storable::dclone($super->{qualifiers}{$qualifier}{value});
					}
				}
				elsif(defined $qualifiers->{$qualifier}{value}) {
					if(ref($qualifiers->{$qualifier}{value}) eq '') {
						$target->{qualifiers}{$qualifier}{value}=$qualifiers->{$qualifier}{value};
					}
					else {
						$target->{qualifiers}{$qualifier}{value}=Storable::dclone($qualifiers->{$qualifier}{value});
					}
				}
			}
		}
	}

	# Now copy properties, methods, and references
	$target->{properties}=Storable::dclone($super->{properties}) if defined $super->{properties};
	$target->{methods}=Storable::dclone($super->{methods}) if defined $super->{methods};
	$target->{references}=Storable::dclone($super->{references}) if defined $super->{references};
	# Now set any qualifiers that do not propogate to their default value...
	foreach my $qualifier (keys %$qualifiers) {
		if(defined $qualifiers->{$qualifier}{flavor}{restricted}) {
			if(defined $qualifiers->{$qualifier}{scope}{property} || defined $qualifiers->{$qualifier}{scope}{all}) {
				setdefaults($target->{properties}, $qualifiers->{$qualifier});
			}
			if(defined $qualifiers->{$qualifier}{scope}{reference} || defined $qualifiers->{$qualifier}{scope}{all}) {
				setdefaults($target->{references}, $qualifiers->{$qualifier});
			}
			if(defined $qualifiers->{$qualifier}{scope}{method} || defined $qualifiers->{$qualifier}{scope}{all}) {
				setdefaults($target->{methods}, $qualifiers->{$qualifier});
			}
			if(defined $qualifiers->{$qualifier}{scope}{parameter} || defined $qualifiers->{$qualifier}{scope}{all}) {
				foreach my $method (keys %{$target->{methods}}) {
					setdefaults($target->{methods}{$method}{parameters}, $qualifiers->{$qualifier});
				}
			}
		}
	}

	# Finally, set superclass
	$target->{superclass}=$super->{name};
}

sub fill_qualifiers
{
	my $target=shift;
	my $scope=shift;
	my $qualifiers=shift;

	foreach my $qualifier (keys %$qualifiers) {
		if(defined $qualifiers->{$qualifier}{scope}{$scope} || defined $qualifiers->{$qualifier}{scope}{all}) {
			if(!defined $target->{$qualifier}) {
				$target->{$qualifier} = {type=>$qualifiers->{$qualifier}{type}};
				$target->{$qualifier}{array}=$qualifiers->{$qualifier}{array} if(defined $qualifiers->{$qualifier}{array});
				if(defined $qualifiers->{$qualifier}{value}) {
					if(ref($qualifiers->{$qualifier}{value}) eq '') {
						$target->{$qualifier}{value}=$qualifiers->{$qualifier}{value};
					}
					else {
						$target->{$qualifier}{value}=Storable::dclone($qualifiers->{$qualifier}{value}) if(defined $qualifiers->{$qualifier}{value});
					}
				}
			}
		}
	}
}

sub value_parser_state
{
	my $type=shift;

	return 'INTEGER' if($type eq 'uint8');
	return 'INTEGER' if($type eq 'uint16');
	return 'INTEGER' if($type eq 'uint32');
	return 'INTEGER' if($type eq 'uint64');
	return 'INTEGER' if($type eq 'sint8');
	return 'INTEGER' if($type eq 'sint16');
	return 'INTEGER' if($type eq 'sint32');
	return 'INTEGER' if($type eq 'sint64');
	return 'REAL' if($type eq 'real32');
	return 'REAL' if($type eq 'real64');
	return 'PARSE_STRING' if($type eq 'string');
	return 'CHAR' if($type eq 'char16');
	return 'BOOLEAN' if($type eq 'boolean');
	return 'DATETIME' if($type eq 'datetime');
	return '';
}

sub parse_MOF
{
	my $fname=shift;
	my $old=shift;
	my $line='';
	my @handles;
	my @filenames;
	my @linenums;
	my @linepos;
	my $state='SKIP_WHITESPACE';
	my @state_stack=('OPEN');
	my %production;
	my %qualifiers;
	my %classes;
	my %instances;
	my %associations;
	my %indications;
	my $token='';		# Used to capture tokens
	my %string;			# Used to capture strings
	my $identifier='';	# Target of the IDENTIFIER state
	my $value;			# Target of the INTEGER, REAL, PARSE_STRING, CHAR, BOOLEAN, and DATETIME states
	my $type;			# Temporary storage for type until other details (such as name and property/method/reference) is known
	my $array;			# Temporary storage for the array subscript to a type
	my $method='';		# Temorary storage of current method name
	my $basepath=$fname;
	$basepath =~ s|([/\\])[^/\\]*$|$1|;
	my %dataTypes = (uint8=>'',sint8=>'',uint16=>'',sint16=>'',uint32=>'',sint32=>'',uint64=>'',sint64=>'',real32=>'',real64=>'',char16=>'',string=>'',boolean=>'',datetime=>'');
	my %scopetypes = (class=>'', association=>'', indication=>'', qualifier=>'', property=>'', reference=>'', method=>'', parameter=>'', any=>'');
	my %flavortypes = (enableoverride=>'', disableoverride=>'', restricted=>'', tosubclass=>'', translatable=>'');
	my %declarationtypes = (association=>'', indication=>'');
	my %qualifierlist;
	my $char16;

	$old=$old->{DATA} if(defined $old->{DATA});
	if(defined $old) {
		%classes=%{$old->{classes}} if(ref($old->{classes}) eq 'HASH');
		%associations=%{$old->{associations}} if(ref($old->{associations}) eq 'HASH');
		%indications=%{$old->{indications}} if(ref($old->{indications}) eq 'HASH');
		%qualifiers=%{$old->{qualifiers}} if(ref($old->{qualifiers}) eq 'HASH');
		%instances=%{$old->{instances}} if(ref($old->{instances}) eq 'HASH');
	}
	$filenames[$#filenames+1] = $fname;
	open($handles[$#handles+1], "<", $filenames[$#filenames]);
	$linenums[$#handles]=0;
line:while($#handles >= 0) {
		my $handle=$handles[$#handles];
		while (my $line = <$handle>) {
			last if(!defined $line);
			$linenums[$#handles]++;
			$linepos[$#handles]=0;
			while($linepos[$#handles] < length($line)) {
				my $char=substr($line, $linepos[$#handles]++, 1);
				if($state eq 'OPEN') {
					if($char eq '#') {
						$state = 'PRAGMA_START';
						$token=$char;
						next;
					}
					elsif($char eq '[') {
						# Can be a class or instance declaration
						%production=();
						push @state_stack, $state;
						push @state_stack, 'SKIP_WHITESPACE';
						push @state_stack, 'CLASS_QUALIFIER_LIST_END';
						push @state_stack, 'QUALIFIER_LIST';
						$identifier='';
						$state='IDENTIFIER';
						next;
					}
					elsif(lc($char) eq 'q') {
						%production=();
						push @state_stack, $state;
						push @state_stack, 'SKIP_WHITESPACE';
						$state = 'QUALIFIER_START';
						$token=$char;
						next;
					}
					elsif(lc($char) eq 'i') {
						%production=();
						push @state_stack, $state;
						push @state_stack, 'SKIP_WHITESPACE';
						$state = 'INSTANCE_START';
						$token=$char;
						next;
					}
					elsif(lc($char) eq 'c') {
						%production=();
						push @state_stack, $state;
						push @state_stack, 'SKIP_WHITESPACE';
						$state = 'CLASS_START';
						$token=$char;
						next;
					}
				}

				#####################
				## Comment Parsing ##
				#####################
				elsif($state eq 'ONE_SLASH') {
					if($char eq '/') {
						$state = 'LINE_COMMENT';
						next;
					}
					elsif($char eq '*') {
						$state = 'BLOCK_COMMENT';
						next;
					}
				}
				elsif($state eq 'LINE_COMMENT') {
					if($char eq "\n" || $char eq "\r") {
						$state = pop @state_stack;
						$linepos[$#handles]--;
					}
					next;
				}
				elsif($state eq 'BLOCK_COMMENT') {
					if($char eq '*') {
						$state = 'BLOCK_COMMENT_END';
					}
					next;
				}
				elsif($state eq 'BLOCK_COMMENT_END') {
					if($char eq '/') {
						$state = pop @state_stack;
					}
					else {
						$state = 'BLOCK_COMMENT';
					}
					next;
				}

				####################
				## Generic Parses ##
				####################
				elsif($state eq 'PARSE_STRING') {
					if(!defined $string{quotes}) {
						%string=(quotes=>0, escape=>0, hval=>0, hex=>'', value=>'');
					}
					if(!$string{quotes}) {
						if($char eq '"') {
							$string{quotes}=1;
							next;
						}
						elsif($char eq '/') {
							push @state_stack, $state;
							$state = 'ONE_SLASH';
							next;
						}
						elsif($char =~ /\s/s) {
							next;
						}
						else {
							$linepos[$#handles]--;
							$state = pop @state_stack;
							$value=$string{value};
							next;
						}
					}
					else {
						if($string{escape}) {
							if($char eq 'b') {
								$string{value} .= "\b";
								$string{escape}=0;
								next;
							}
							elsif($char eq 't') {
								$string{value} .= "\t";
								$string{escape}=0;
								next;
							}
							elsif($char eq 'n') {
								$string{value} .= "\n";
								$string{escape}=0;
								next;
							}
							elsif($char eq 'f') {
								$string{value} .= "\f";
								$string{escape}=0;
								next;
							}
							elsif($char eq 'r') {
								$string{value} .= "\r";
								$string{escape}=0;
								next;
							}
							elsif($char eq '"') {
								$string{value} .= '"';
								$string{escape}=0;
								next;
							}
							elsif($char eq "'") {
								$string{value} .= "'";
								$string{escape}=0;
								next;
							}
							elsif($char eq '\\') {
								$string{value} .= '\\';
								$string{escape}=0;
								next;
							}
							elsif(lc($char) eq 'x') {
								$string{escape}=0;
								$string{hval}=1;
								$string{hex}='';
								next;
							}
						}
						elsif($string{hval}) {
							if($char =~ /[A-Fa-f0-9]/) {
								$string{hex} .= $char;
								if(length($string{hex})==4) {
									$string{value} .= ord(hex($string{hex}));
									$string{hval}=0;
								}
								next;
							}
							else {
								$string{value} .= ord(hex($string{hex}));
								$string{hval}=0;
								next;
							}
						}
						else {
							if($char eq '\\') {
								$string{escape}=1;
								next;
							}
							elsif($char eq '"') {
								$string{quotes}=0;
								next;
							}
							$string{value} .= $char;
							next;
						}
					}
				}
				elsif($state eq 'IDENTIFIER') {
					if (length($identifier) == 0) {
						if($char =~ /\s/s) {
							next;
						}
						elsif($char =~ /[A-Za-z_]/) {
							$identifier .= $char;
							next;
						}
					}
					else {
						if($char =~ /[A-Za-z0-9_]/) {
							$identifier .= $char;
							next;
						}
						elsif($char =~ /\s/s) {
							$state = 'SKIP_WHITESPACE';
							next;
						}
						else {
							$state = pop @state_stack;
							$linepos[$#handles]--;
							next;
						}
					}
				}
				elsif($state eq 'SKIP_WHITESPACE') {
					if($char =~ /\s/s) {
						next;
					}
					elsif($char eq '/') {
						push @state_stack, $state;
						$state='ONE_SLASH';
						next;
					}
					else {
						$state = pop @state_stack;
						$linepos[$#handles]--;
						next;
					}
				}
				elsif($state eq 'DATETIME') {
					$value ='';
					$linepos[$#handles]--;
					push @state_stack, 'DATETIME_PARSE';
					$state='PARSE_STRING';
					next;
				}
				elsif($state eq 'DATETIME_PARSE') {
					#TODO Parse date/time types.
					$linepos[$#handles]--;
					$state=pop @state_stack;
					next;
				}
				elsif($state eq 'BOOLEAN') {
					$value .= $char;
					if(lc($value) eq 'true') {
						$state = pop @state_stack;
						next;
					}
					elsif(lc($value) eq 'false') {
						# TODO: Should this be logically false?
						$state = pop @state_stack;
						next;
					}
					elsif(substr("true", 0, length($value)) eq lc($value)) {
						next;
					}
					elsif(substr("false", 0, length($value)) eq lc($value)) {
						next;
					}
				}
				elsif($state eq 'NULL') {
					$value .= $char;
					if(lc($value) eq 'null') {
						$value=undef;
						$state = pop @state_stack;
						next;
					}
					elsif(substr("null", 0, length($value)) eq lc($value)) {
						next;
					}
				}
				elsif($state eq 'CHECK_NULL') {
					$linepos[$#handles]--;
					if($char eq 'n') {
						pop @state_stack;
						$state = 'NULL';
						next;
					}
					else {
						$state = pop @state_stack;
						next;
					}
				}
				elsif($state eq 'INTEGER') {
					my $oldvalue=$value;
					my $oldvalid=valid_MOF_integer($value);
					$value .= $char;
					my $valid=valid_MOF_integer($value);
					if($valid) {
						next;
					}
					if($oldvalid > 1) {
						$linepos[$#handles]--;
						# TODO Check range.
						$value=parse_MOF_integer($oldvalue);
						$state = pop @state_stack;
						next;
					}
				}
				elsif($state eq 'SEMICOLON_TERMINATER') {
					if($char eq ';') {
						$state = 'SKIP_WHITESPACE';
						next;
					}
				}
				elsif($state eq 'QUALIFIER_LIST') {
					if(defined $declarationtypes{lc($identifier)} || defined $qualifiers{lc($identifier)}) {
						$qualifierlist{lc($identifier)}{type}=$qualifiers{lc($identifier)}{type};
						$qualifierlist{lc($identifier)}{array}=$qualifiers{lc($identifier)}{array} if(defined $qualifiers{lc($identifier)}{array});
						if($qualifierlist{lc($identifier)}{type} eq 'boolean') {
							$qualifierlist{lc($identifier)}{value}='true';
						}
						elsif(defined $qualifierlist{lc($identifier)}{array}) {
							$qualifierlist{lc($identifier)}{value}=[];
						}
						if($char eq ',') {
							push @state_stack, 'QUALIFIER_LIST';
							$identifier='';
							$state='IDENTIFIER';
							next;
						}
						elsif($char eq '(') {
							# Parse value
							push @state_stack, 'QUALIFIER_LIST_VALUE_DONE';
							push @state_stack, 'SKIP_WHITESPACE';

							my $newstate=value_parser_state($qualifiers{lc($identifier)}{type});
							if($newstate eq '') {
								pop @state_stack;
							}
							else {
								%string=();
								$value='';
								push @state_stack, $newstate;
								push @state_stack, 'CHECK_NULL';
								$state = 'SKIP_WHITESPACE';
								next;
							}
						}
						elsif($char eq '{') {
							push @state_stack, 'QUALIFIER_ARRAY_VALUE_DONE';
							push @state_stack, 'SKIP_WHITESPACE';

							my $newstate=value_parser_state($qualifiers{lc($identifier)}{type});
							if($newstate eq '') {
								pop @state_stack;
							}
							else {
								%string=();
								$value='';
								push @state_stack, $newstate;
								push @state_stack, 'CHECK_NULL';
								$state = 'SKIP_WHITESPACE';
								next;
							}
						}
						elsif($char eq ']') {
							$token='';
							$identifier='';
							$state='SKIP_WHITESPACE';
							next;
						}
					}
					else {
						# Implicitly defined qualifier
						$qualifierlist{lc($identifier)}{value}=$qualifiers{lc($identifier)}{value};
						$qualifierlist{lc($identifier)}{type}='string';
						if($char eq ',') {
							push @state_stack, 'QUALIFIER_LIST';
							$identifier='';
							$state='IDENTIFIER';
							next;
						}
						elsif($char eq '(') {
							# Parse value
							push @state_stack, 'QUALIFIER_LIST_VALUE_DONE';
							push @state_stack, 'SKIP_WHITESPACE';

							%string=();
							push @state_stack, 'PARSE_STRING';
							push @state_stack, 'CHECK_NULL';
							$state = 'SKIP_WHITESPACE';
							next;
						}
						elsif($char eq ':') {
							# TODO: (deprecated) implicit qualifier flavours
						}
						print "Qualifier/Declaration $identifier is unknown!\n";
					}
				}
				elsif($state eq 'QUALIFIER_ARRAY_VALUE_DONE') {
					push @{$qualifierlist{lc($identifier)}{value}}, $value;
					$value = '';
					if($char eq ',') {
						push @state_stack, 'QUALIFIER_ARRAY_VALUE_DONE';
						push @state_stack, 'SKIP_WHITESPACE';

						my $newstate=value_parser_state($qualifiers{lc($identifier)}{type});
						if($newstate eq '') {
							pop @state_stack;
						}
						else {
							%string=();
							$value='';
							push @state_stack, $newstate;
							push @state_stack, 'CHECK_NULL';
							$state = 'SKIP_WHITESPACE';
							next;
						}
					}
					elsif($char eq '}') {
						push @state_stack, 'QUALIFIER_LIST_AFTER_VALUE_DONE';
						$state='SKIP_WHITESPACE';
						next;
					}
				}
				elsif($state eq 'QUALIFIER_LIST_VALUE_DONE') {
					if($char eq ')') {
						$qualifierlist{lc($identifier)}{value}=$value;
						$value='';
						push @state_stack, 'QUALIFIER_LIST_AFTER_VALUE_DONE';
						$state='SKIP_WHITESPACE';
						next;
					}
				}
				elsif($state eq 'QUALIFIER_LIST_AFTER_VALUE_DONE') {
					if($char eq ',') {
						push @state_stack, 'QUALIFIER_LIST';
						$identifier='';
						$state='IDENTIFIER';
						next;
					}
					elsif($char eq ']') {
						$token='';
						$identifier='';
						$state='SKIP_WHITESPACE';
						next;
					}
					elsif($char eq ':') {
						# TODO (Deprecated) implicit qualifier flavours.
					}
				}

				###########################################
				## Class/Instance/Association/Indication ##
				###########################################
				elsif($state eq 'CLASS_QUALIFIER_LIST_END') {
					# TODO: Validate the scope and flavor of qualifiers.
					$production{qualifiers}={%qualifierlist};
					$linepos[$#handles]--;
					$state = 'INSTANCE_OR_CLASS';
					next;
				}
				elsif($state eq 'INSTANCE_OR_CLASS') {
					$token .= $char;
					if(lc($token) eq 'instance') {
						$state = 'INSTANCE_OF';
						next;
					}
					elsif(lc($token) eq 'class') {
						$identifier='';
						push @state_stack, 'CLASS_NAME';
						$state = 'IDENTIFIER';
						next;
					}
					elsif(substr("instance", 0, length($token)) eq lc($token)) {
						next;
					}
					elsif(substr("class", 0, length($token)) eq lc($token)) {
						next;
					}
				}

				##########################################
				## Class/Association/Indication Parsing ##
				##########################################
				elsif($state eq 'CLASS_START') {
					$token .= $char;
					if(lc($token) eq 'class') {
						$token='';
						$identifier='';
						push @state_stack, 'CLASS_NAME';
						$state = 'IDENTIFIER';
						next;
					}
					elsif(substr("class", 0, length($token)) eq lc($token)) {
						next;
					}
				}
				elsif($state eq 'CLASS_NAME') {
					$linepos[$#handles]--;
					if(!defined $classes{lc($identifier)} && !defined $associations{lc($identifier)} && !defined $indications{lc($identifier)}) {
						if($identifier =~ /^[A-Za-z][A-Za-z0-9]*_[A-Za-z_][A-Za-z0-9_]*$/) {
							$production{name}=$identifier;
							push @state_stack, 'CLASS_SUPERCLASS';
							$state='SKIP_WHITESPACE';
							next;
						}
						else {
							print "Invalid class name $identifier\n";
						}
					}
					else {
						print "Redefinition of $identifier!\n";
					}
				}
				elsif($state eq 'CLASS_SUPERCLASS') {
					if($char eq ':') {
						push @state_stack, 'CLASS_SUPERCLASS_NAME';
						$identifier='';
						$state='IDENTIFIER';
						next;
					}
					elsif($char eq '{') {
						$linepos[$#handles]--;
						$state = 'CLASS_FEATURE';
						if(defined $qualifierlist{association} && $qualifierlist{association}{value} eq 'true') {
							fill_qualifiers($production{qualifiers}, 'association', \%qualifiers);
						}
						elsif(defined $qualifierlist{indication} && $qualifierlist{indication}{value} eq 'true') {
							fill_qualifiers($production{qualifiers}, 'indication', \%qualifiers);
						}
						else {
							fill_qualifiers($production{qualifiers}, 'class', \%qualifiers);
						}
						next;
					}
				}
				elsif($state eq 'CLASS_SUPERCLASS_NAME') {
					if(defined $classes{lc($identifier)}) {
						derive(\%production, $classes{lc($identifier)}, \%qualifiers);
						$linepos[$#handles]--;
						push @state_stack, 'CLASS_FEATURE';
						$state='SKIP_WHITESPACE';
						next;
					}
					elsif(defined $associations{lc($identifier)}) {
						derive(\%production, $associations{lc($identifier)}, \%qualifiers);
						$linepos[$#handles]--;
						push @state_stack, 'CLASS_FEATURE';
						$state='SKIP_WHITESPACE';
						next;
					}
					elsif(defined $indications{lc($identifier)}) {
						derive(\%production, $indications{lc($identifier)}, \%qualifiers);
						$linepos[$#handles]--;
						push @state_stack, 'CLASS_FEATURE';
						$state='SKIP_WHITESPACE';
						next;
					}
					else {
						print "Superclass $identifier not defined\n";
					}
				}
				elsif($state eq 'CLASS_FEATURE') {
					if($char eq '{') {
						push @state_stack, 'CLASS_FEATURE_LIST';
						$state='SKIP_WHITESPACE';
						next;
					}
				}
				elsif($state eq 'CLASS_FEATURE_LIST') {
					%qualifierlist=();
					if($char eq '[') {
						push @state_stack, $state;
						push @state_stack, 'CLASS_FEATURE_QUALIFIER_LIST_END';
						push @state_stack, 'QUALIFIER_LIST';
						$identifier='';
						$state='IDENTIFIER';
						next;
					}
					elsif($char eq '}') {
						if(defined $production{qualifiers}{association} && $production{qualifiers}{association}{value} eq 'true') {
							$associations{lc($production{name})}={%production};
						}
						elsif(defined $production{qualifiers}{indication} && $production{qualifiers}{indication}{value} eq 'true') {
							$indications{lc($production{name})}={%production};
						}
						else {
							$classes{lc($production{name})}={%production};
						}
						push @state_stack, 'SEMICOLON_TERMINATER';
						$state='SKIP_WHITESPACE';
						next;
					}
					else {
						$linepos[$#handles]--;
						push @state_stack, 'CLASS_FEATURE_TYPE';
						$state='IDENTIFIER';
						next;
					}
				}
				elsif($state eq 'CLASS_FEATURE_QUALIFIER_LIST_END') {
					# TODO: Validate the scope and flavor of qualifiers.
					$linepos[$#handles]--;
					push @state_stack, 'CLASS_FEATURE_TYPE';
					$state='IDENTIFIER';
					next;
				}
				elsif($state eq 'CLASS_FEATURE_TYPE') {
					if(defined $dataTypes{lc($identifier)}) {
						$type = lc($identifier);
						$identifier='';
						$linepos[$#handles]--;
						push @state_stack, 'CLASS_FEATURE_NAME';
						$state='IDENTIFIER';
						next;
					}
					elsif(defined $classes{lc($identifier)} || defined $associations{lc($identifier)} || defined $indications{lc($identifier)}) {
						if(defined $production{qualifiers}{association} && $production{qualifiers}{association}{value} eq 'true') {
							$type = lc($identifier);
							$identifier='';
							$linepos[$#handles]--;
							$state = 'CLASS_REFERENCE';
							next;
						}
					}
					else {
						print "Unhandled type $identifier\n";
					}
				}
				elsif($state eq 'CLASS_REFERENCE') {
					$token .= $char;
					if(lc($token) eq 'ref') {
						$token = '';
						push @state_stack, 'CLASS_REFERENCE_NAME';
						$identifier='';
						$state='IDENTIFIER';
						next;
					}
					elsif(substr("ref", 0, length($token)) eq lc($token)) {
						next;
					}
				}
				elsif($state eq 'CLASS_REFERENCE_NAME') {
					$linepos[$#handles]--;
					$production{references}{lc($identifier)}{type}=$type;
					$production{references}{lc($identifier)}{is_ref}='true';
					fill_qualifiers(\%qualifierlist, 'reference', \%qualifiers);
					$production{references}{lc($identifier)}{qualifiers}={%qualifierlist};
					$production{references}{lc($identifier)}{name}=$identifier;
					%qualifierlist=();
					push @state_stack, 'SEMICOLON_TERMINATER';
					$state = 'SKIP_WHITESPACE';
					# TODO: Handle default value
					next;
				}
				elsif($state eq 'CLASS_FEATURE_NAME') {
					if($char eq '[') {
						fill_qualifiers(\%qualifierlist, 'property', \%qualifiers);
						$production{properties}{lc($identifier)}{qualifiers}={%qualifierlist};
						%qualifierlist=();
						$production{properties}{lc($identifier)}{type}=$type;
						$production{properties}{lc($identifier)}{array}='';
						$production{properties}{lc($identifier)}{name}=$identifier;
						push @state_stack, 'CLASS_PROPERTY_NAME_ARRAY';
						$state='SKIP_WHITESPACE';
						next;
					}
					elsif($char eq '=') {
						$production{properties}{lc($identifier)}{type}=$type;
						fill_qualifiers(\%qualifierlist, 'property', \%qualifiers);
						$production{properties}{lc($identifier)}{qualifiers}={%qualifierlist};
						$production{properties}{lc($identifier)}{name}=$identifier;
						%qualifierlist=();
						$linepos[$#handles]--;
						$state = 'CLASS_PROPERTY_DEFAULT';
						next;
					}
					elsif($char eq '(') {
						#Method...
						fill_qualifiers(\%qualifierlist, 'method', \%qualifiers);
						$production{methods}{lc($identifier)}{qualifiers}={%qualifierlist};
						%qualifierlist=();
						$production{methods}{lc($identifier)}{type}=$type;
						$production{methods}{lc($identifier)}{name}=$identifier;
						$method=lc($identifier);
						$identifier='';
						push @state_stack, 'CLASS_PARAMETER_LIST';
						$state = 'SKIP_WHITESPACE';
						next;
					}
					elsif($char eq ';') {
						$linepos[$#handles]--;
						fill_qualifiers(\%qualifierlist, 'property', \%qualifiers);
						$production{properties}{lc($identifier)}{qualifiers}={%qualifierlist};
						%qualifierlist=();
						$production{properties}{lc($identifier)}{type}=$type;
						$production{properties}{lc($identifier)}{name}=$identifier;
						$state = 'SEMICOLON_TERMINATER';
						next;
					}
				}
				elsif($state eq 'CLASS_PARAMETER_LIST') {
					if($char eq '[') {
						%qualifierlist=();
						push @state_stack, 'CLASS_PARAMETER_QUALIFIER_LIST_END';
						push @state_stack, 'QUALIFIER_LIST';
						$identifier='';
						$state='IDENTIFIER';
						next;
					}
					elsif($char eq ')') {
						push @state_stack, 'SEMICOLON_TERMINATER';
						$state='SKIP_WHITESPACE';
						next;
					}
					else {
						$linepos[$#handles]--;
						push @state_stack, 'CLASS_PARAMETER_TYPE';
						$identifier='';
						$state='IDENTIFIER';
						next;
					}
				}
				elsif($state eq 'CLASS_PARAMETER_QUALIFIER_LIST_END') {
					# TODO: Validate the scope and flavor of qualifiers.
					$linepos[$#handles]--;
					push @state_stack, 'CLASS_PARAMETER_TYPE';
					$state='IDENTIFIER';
					next;
				}
				elsif($state eq 'CLASS_PARAMETER_TYPE') {
					if(defined $dataTypes{lc($identifier)}) {
						$type = lc($identifier);
						$identifier='';
						$linepos[$#handles]--;
						push @state_stack, 'CLASS_PARAMETER_NAME';
						$state='IDENTIFIER';
						next;
					}
					elsif(defined $classes{lc($identifier)} || defined $associations{lc($identifier)} || defined $indications{lc($identifier)}) {
						$type = lc($identifier);
						$identifier='';
						$linepos[$#handles]--;
						$state = 'PARAMETER_REFERENCE';
						next;
					}
				}
				elsif($state eq 'CLASS_PARAMETER_NAME') {
					$production{methods}{$method}{parameters}{lc($identifier)}{type}=$type;
					$production{methods}{$method}{parameters}{lc($identifier)}{name}=$identifier;
					fill_qualifiers(\%qualifierlist, 'parameter', \%qualifiers);
					$production{methods}{$method}{parameters}{lc($identifier)}{qualifiers}={%qualifierlist};
					if($char eq '[') {
						$token='';
						$production{methods}{$method}{parameters}{lc($identifier)}{array}='';
						$state = 'PARAMETER_NAME_ARRAY';
						next;
					}
					elsif($char eq ',') {
						push @state_stack, 'CLASS_PARAMETER_LIST';
						$state = 'SKIP_WHITESPACE';
						next;
					}
					elsif($char eq ')') {
						push @state_stack, 'SEMICOLON_TERMINATER';
						$state = 'SKIP_WHITESPACE';
						next;
					}
				}
				elsif($state eq 'PARAMETER_REFERENCE') {
					$token .= $char;
					if(lc($token) eq 'ref') {
						$token = '';
						push @state_stack, 'PARAMETER_REFERENCE_NAME';
						$identifier='';
						$state='IDENTIFIER';
						next;
					}
					elsif(substr("ref", 0, length($token)) eq lc($token)) {
						next;
					}
				}
				elsif($state eq 'PARAMETER_REFERENCE_NAME') {
					$production{methods}{$method}{parameters}{lc($identifier)}{type}='ref';
					fill_qualifiers(\%qualifierlist, 'parameter', \%qualifiers);
					$production{methods}{$method}{parameters}{lc($identifier)}{qualifiers}={%qualifierlist};
					$production{methods}{$method}{parameters}{lc($identifier)}{name}=$identifier;
					if($char eq '[') {
						$token='';
						$production{methods}{$method}{parameters}{lc($identifier)}{array}='';
						$state = 'PARAMETER_NAME_ARRAY';
						next;
					}
					elsif($char eq ',') {
						push @state_stack, 'CLASS_PARAMETER_LIST';
						$state = 'SKIP_WHITESPACE';
						next;
					}
					elsif($char eq ')') {
						push @state_stack, 'SEMICOLON_TERMINATER';
						$state = 'SKIP_WHITESPACE';
						next;
					}
				}
				elsif($state eq 'PARAMETER_NAME_ARRAY') {
					if($char =~ /[0-9]/) {
						$production{properties}{lc($identifier)}{array} .= $char;
						next;
					}
					elsif($char eq ']') {
						push @state_stack, 'PARAMETER_NAME_ARRAY_DONE';
						$state='SKIP_WHITESPACE';
						next;
					}
				}
				elsif($state eq 'PARAMETER_NAME_ARRAY_DONE') {
					if($char eq ',') {
						push @state_stack, 'CLASS_PARAMETER_LIST';
						$state = 'SKIP_WHITESPACE';
						next;
					}
					elsif($char eq ')') {
						push @state_stack, 'SEMICOLON_TERMINATER';
						$state = 'SKIP_WHITESPACE';
						next;
					}
				}
				elsif($state eq 'CLASS_PROPERTY_NAME_ARRAY') {
					if($char =~ /[0-9]/) {
						$production{properties}{lc($identifier)}{array} .= $char;
						next;
					}
					elsif($char eq ']') {
						push @state_stack, 'CLASS_PROPERTY_DEFAULT';
						$state='SKIP_WHITESPACE';
						next;
					}
				}
				elsif($state eq 'CLASS_PROPERTY_DEFAULT') {
					if($char eq '=') {
						push @state_stack, 'CLASS_PROPERTY_DEFAULT_VALUE';
						$state = 'SKIP_WHITESPACE';
						next;
					}
					elsif($char eq ';') {
						$linepos[$#handles]--;
						$state = 'SEMICOLON_TERMINATER';
						next;
					}
				}
				elsif($state eq 'CLASS_PROPERTY_DEFAULT_VALUE') {
					if(defined $production{properties}{lc($identifier)}{array}) {
						if($char eq '{') {
							push @state_stack, 'CLASS_PROPERTY_DEFAULT_ARRAY_VALUE_DONE';
							push @state_stack, 'SKIP_WHITESPACE';

							my $newstate=value_parser_state($production{properties}{lc($identifier)}{type});
							if($newstate eq '') {
								pop @state_stack;
							}
							else {
								$value='';
								%string=();
								push @state_stack, $newstate;
								push @state_stack, 'CHECK_NULL';
								$state = 'SKIP_WHITESPACE';
								next;
							}
						}
					}
					else {
						# Parse value
						$linepos[$#handles]--;
						push @state_stack, 'CLASS_PROPERTY_DEFAULT_VALUE_DONE';
						push @state_stack, 'SKIP_WHITESPACE';

						my $newstate=value_parser_state($production{properties}{lc($identifier)}{type});
						if($newstate eq '') {
							pop @state_stack;
						}
						else {
							$value='';
							%string=();
							push @state_stack, $newstate;
							push @state_stack, 'CHECK_NULL';
							$state = 'SKIP_WHITESPACE';
							next;
						}
					}
				}
				elsif($state eq 'CLASS_PROPERTY_DEFAULT_ARRAY_VALUE_DONE') {
					push @{$production{properties}{lc($identifier)}{default}}, $value;
					$value = '';
					if($char eq ',') {
						push @state_stack, 'CLASS_PROPERTY_DEFAULT_ARRAY_VALUE_DONE';
						push @state_stack, 'SKIP_WHITESPACE';

						my $newstate=value_parser_state($production{properties}{lc($identifier)}{type});
						if($newstate eq '') {
							pop @state_stack;
						}
						else {
							$value='';
							%string=();
							push @state_stack, $newstate;
							push @state_stack, 'CHECK_NULL';
							$state = 'SKIP_WHITESPACE';
							next;
						}
					}
					elsif($char eq '}') {
						push @state_stack, 'SEMICOLON_TERMINATER';
						$state = 'SKIP_WHITESPACE';
						next;
					}
				}
				elsif($state eq 'CLASS_PROPERTY_DEFAULT_VALUE_DONE') {
					$production{properties}{lc($identifier)}{default}=$value;
					$linepos[$#handles]--;
					push @state_stack, 'SEMICOLON_TERMINATER';
					$state = 'SKIP_WHITESPACE';
					next;
				}

				####################
				## Pragma Parsing ##
				####################
				elsif($state eq 'PRAGMA_START') {
					$token .= $char;
					if(lc($token) eq '#pragma') {
						%production=(type=>'#pragma');
						$token = '';
						push @state_stack, 'PRAGMA_NAME';
						$identifier='';
						$state='IDENTIFIER';
						next;
					}
					elsif(substr("#pragma", 0, length($token)) eq lc($token)) {
						next;
					}
				}
				elsif($state eq 'PRAGMA_NAME') {
					if($char eq '(') {
						$production{name}=$identifier;
						$identifier='';
						push @state_stack, 'PRAGMA_PARAMETER';
						%string=();
						$state = 'PARSE_STRING';
						next;
					}
				}
				elsif($state eq 'PRAGMA_PARAMETER') {
					if($char =~ /\s/s) {
						next;
					}
					elsif($char eq ')') {
						$production{parameter} = $string{value};
						%string=();
						push @state_stack,'OPEN';
						$state = 'SKIP_WHITESPACE';
						if(lc($production{name}) eq 'include') {
							$filenames[$#filenames+1] = $basepath.$production{parameter};
							if(open($handles[$#handles+1], "<", $filenames[$#filenames])) {
								$linenums[$#handles]=0;
								next line;
							}
							pop @filenames;
							pop @handles;
							print "Error opening file $basepath$production{parameter}!\n";
						}
						else {
							next;
						}
					}
				}

				#######################
				## Qualifier Parsing ##
				#######################
				elsif($state eq 'QUALIFIER_START') {
					$token .= $char;
					if(lc($token) eq 'qualifier') {
						$token = '';
						push @state_stack, 'QUALIFIER_NAME';
						$identifier='';
						$state='IDENTIFIER';
						next;
					}
					elsif(substr("qualifier", 0, length($token)) eq lc($token)) {
						next;
					}
				}
				elsif($state eq 'QUALIFIER_NAME') {
					if($char eq ':') {
						$production{name}=$identifier;
						$identifier='';
						push @state_stack, 'QUALIFIER_TYPE';
						$state='IDENTIFIER';
						next;
					}
				}
				elsif($state eq 'QUALIFIER_TYPE') {
					if(defined $dataTypes{lc($identifier)}) {
						$production{type}=lc($identifier);
						$identifier='';
						if($char eq '[') {
							push @state_stack, 'QUALIFIER_ARRAY';
							$state='SKIP_WHITESPACE';
							next;
						}
						elsif($char eq '=') {
							$state = 'QUALIFIER_DEFAULT_VALUE';
							$linepos[$#handles]--;
							next;
						}
						elsif($char eq ',') {
							if($production{type} eq 'boolean') {
								$production{value}='true';
							}
							elsif(defined $production{array}) {
								$production{value}=[];
							}
							$state = 'QUALIFIER_SCOPE';
							$linepos[$#handles]--;
							next;
						}
					}
				}
				elsif($state eq 'QUALIFIER_ARRAY') {
					if($char eq ']') {
						$production{array}='';
						push @state_stack, 'QUALIFIER_DEFAULT_VALUE';
						$state='SKIP_WHITESPACE';
						next;
					}
					elsif($char =~ /[1-9]/) {
						$token=$char;
						$state='QUALIFIER_ARRAY_VALUE';
						next;
					}
				}
				elsif($state eq 'QUALIFIER_ARRAY_VALUE') {
					if($char =~ /[0-9]/) {
						$token .= $char;
						next;
					}
					elsif($char eq ']') {
						$production{array}=$token+0;
						$token='';
						push @state_stack, 'QUALIFIER_DEFAULT_VALUE';
						$state='SKIP_WHITESPACE';
						next;
					}
				}
				elsif($state eq 'QUALIFIER_DEFAULT_VALUE') {
					if($char eq '=') {
						push @state_stack, 'QUALIFIER_DEFAULT_VALUE_SPEC';
						$state='SKIP_WHITESPACE';
						next;
					}
					elsif($char eq ',') {
						if($production{type} eq 'boolean') {
							$production{value}='true';
						}
						elsif(defined $production{array}) {
							$production{value}=[];
						}
						$state = 'QUALIFIER_SCOPE';
						$linepos[$#handles]--;
						next;
					}
				}
				elsif($state eq 'QUALIFIER_DEFAULT_VALUE_SPEC') {
					$value='';
					$linepos[$#handles]--;
					if(defined $production{array}) {
						# TODO - Parse arrays...
					}
					else {
						push @state_stack, 'QUALIFIER_DEFAULT_VALUE_DONE';

						if($char eq 'n') {
							$state='NULL';
							next;
						}
						else {
							my $newstate = value_parser_state($production{type});
							if($newstate eq '') {
								pop @state_stack;
							}
							else {
								$value='';
								%string=();
								push @state_stack, $newstate;
								$state = 'SKIP_WHITESPACE';
								next;
							}
						}
					}
				}
				elsif($state eq 'QUALIFIER_DEFAULT_VALUE_DONE') {
					$linepos[$#handles]--;
					$production{value}=$value;
					$value='';
					push @state_stack, 'QUALIFIER_SCOPE';
					$state='SKIP_WHITESPACE';
					next;
				}
				elsif($state eq 'QUALIFIER_SCOPE') {
					if($char eq ',') {
						push @state_stack, 'QUALIFIER_SCOPE_IDENTIFIER';
						$state='SKIP_WHITESPACE';
						$token='';
						next;
					}
				}
				elsif($state eq 'QUALIFIER_SCOPE_IDENTIFIER') {
					$token .= $char;
					if(lc($token) eq 'scope') {
						$token = '';
						push @state_stack, 'QUALIFIER_SCOPE_LIST_START';
						$state='SKIP_WHITESPACE';
						next;
					}
					elsif(substr("scope", 0, length($token)) eq lc($token)) {
						next;
					}
				}
				elsif($state eq 'QUALIFIER_SCOPE_LIST_START') {
					if($char eq '(') {
						push @state_stack, 'QUALIFIER_SCOPE_LIST';
						$identifier='';
						$state='IDENTIFIER';
						next;
					}
				}
				elsif($state eq 'QUALIFIER_SCOPE_LIST') {
					if(defined $scopetypes{lc($identifier)}) {
						$production{scope}{lc($identifier)}=1;
						if($char eq ',') {
							push @state_stack, 'QUALIFIER_SCOPE_LIST';
							$identifier='';
							$state='IDENTIFIER';
							next;
						}
						elsif($char eq ')') {
							push @state_stack, 'QUALIFIER_FLAVOR';
							$identifier='';
							$state='SKIP_WHITESPACE';
							next;
						}
					}
				}
				elsif($state eq 'QUALIFIER_FLAVOR') {
					if($char eq ',') {
						push @state_stack, 'QUALIFIER_FLAVOR_IDENTIFIER';
						$state='SKIP_WHITESPACE';
						$token='';
						next;
					}
					elsif($char eq ';') {
						$qualifiers{lc($production{name})}={%production};
						$state = pop @state_stack;
						next;
					}
				}
				elsif($state eq 'QUALIFIER_FLAVOR_IDENTIFIER') {
					$token .= $char;
					if(lc($token) eq 'flavor') {
						$token = '';
						push @state_stack, 'QUALIFIER_FLAVOR_LIST_START';
						$state='SKIP_WHITESPACE';
						next;
					}
					elsif(substr("flavor", 0, length($token)) eq lc($token)) {
						next;
					}
				}
				elsif($state eq 'QUALIFIER_FLAVOR_LIST_START') {
					if($char eq '(') {
						push @state_stack, 'QUALIFIER_FLAVOR_LIST';
						$identifier='';
						$state='IDENTIFIER';
						next;
					}
				}
				elsif($state eq 'QUALIFIER_FLAVOR_LIST') {
					if(defined $flavortypes{lc($identifier)}) {
						$production{flavor}{lc($identifier)}=1;
						if($char eq ',') {
							push @state_stack, 'QUALIFIER_FLAVOR_LIST';
							$identifier='';
							$state='IDENTIFIER';
							next;
						}
						elsif($char eq ')') {
							$qualifiers{lc($production{name})}={%production};
							push @state_stack, 'SEMICOLON_TERMINATER';
							$identifier='';
							$state='SKIP_WHITESPACE';
							next;
						}
					}
				}
				else {
					print "Unhandled state $state\n";
					next;
				}

				carp "Error in $state (",join("->",@state_stack),") at char '$char' in $filenames[$#filenames] line $linenums[$#handles]\n";
				$line =~ s/\t/ /g;
				carp sprintf("%s\n%*s^\n", $line, $linepos[$#handles]-1, '');
				return;
			}
		}
		close(pop @handles);
		pop @filenames;
		pop @linenums;
		pop @linepos;
	}

	return {classes=>{%classes}, associations=>{%associations}, indications=>{%indications}, qualifiers=>{%qualifiers}, instances=>{%instances}};
}

1; # Magic true value required at end of module
__END__