parser.pm

platform file from motorola kernel code

# The source files are wholly original Motorola proprietary work now being 
# licensed as BSD, the following Copyright Notice will be added to each source 
# code file, documentation and other materials with the distribution:
# 
#       Copyright  2006, Motorola, All Rights Reserved.
# 
# This program is licensed under a BSD license with the following terms:
# 
# Redistribution and use in source and binary forms, with or without 
# modification, are permitted provided that the following conditions are met:
#
# - Redistributions of source code must retain the above copyright notice, 
#   this list of conditions and the following disclaimer. 
#
# - Redistributions in binary form must reproduce the above copyright notice, 
#   this list of conditions and the following disclaimer in the documentation 
#   and/or other materials provided with the distribution. 
#
# - Neither the name of the MOTOROLA nor the names of its contributors may be 
#   used to endorse or promote products derived from this software without 
#   specific prior written permission.
#
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 
# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE 
# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 
# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 
# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 
# POSSIBILITY OF SUCH DAMAGE.
#


package Bom::Parser;

#==============================================================================
#
#    General Description:
#    Parser a bom file into a collection of entry objects
#
#==============================================================================

use strict;
use File::Basename;
use Bom::Entry;
use Ref;

my $MacroRe = qr/[a-z]\w*/io;

sub new {
	my ($this,$callback) = @_;
	my $class = ref($this) || $this;

	my $self = {
		callback => $callback,
		entries  => {},
		dict     => undef,
		ldict    => undef,
		defaults => {},
	};
	bless($self,$class);
}

sub read_bom {
	my ($self,$bom) = @_;
	local $self->{defaults} = Ref::copy($self->{defaults});

	my $fh;
	if (defined(fileno($bom))) {
		$fh = $bom;
		$bom = 'FH';
	} else {
		open($fh,'<',$bom) || die("open: $bom: $!\n");
	}

	my $buf = do { local $/ = undef; <$fh> };
	$self->read_string($bom,$buf);

	();
}

sub write_bom {
	my ($self, $bom) = @_;
	open (my $fh,'>',$bom) || die("open: $bom: $!\n");
	print($fh $self->stringify_entries);
	close($fh) || die("close: $bom: $!\n");
	();
}


sub read_string {
	my ($self,$bomsrc,$buf) = @_;
	my $base = dirname($bomsrc);
	if ($base eq '.') {
		$base = '';
	} else {
		$base .= '/';
	}

	local $self->{filebase} = $base;
	local $self->{file} = $bomsrc;
	local $self->{line} = 0;
	local $self->{string};

	my @frame = (1);
	my @entry;

	while ($buf =~ m{^(.*)$}mgo) {
		my $string = $1;
		$string =~ s/\s+$//o;
		$self->{string} = $string;
		$self->{line}++;

		# strip comments
		$string =~ s/^\s*#.*//o;

		# process non-whitespace only lines
		next if ($string =~ /^\s*$/o);

		if ($string =~ /^\s*@(.*)$/o) { # process conditional commands
			$self->process_cmd(\@frame,$1);
		} elsif ($frame[-1] > 0) { # process line if current frame is true
			$self->process_string(\@entry,$string)
		}
	}
	$self->{string} = 'EOF';

	# flush any remaining entries
	map { $self->add_entry($_) } @entry;

	# check for unclosed if's
	if (my $n = $#frame) {
		my $s = ($n == 1) ? '' : 's';
		$self->_line_error("$n unclosed if context$s");
	}

	();
}

# process @cmd lines
# frame state: -1 = been true, 0 = false, 1 = true
sub process_cmd {
	my ($self,$frames,$string) = @_;

	my ($cmd,$args) = split(/\s+/o,$string,2);
	my $noargs = ($args eq '');
	my $stateh = \$frames->[-1];

	if ($cmd eq 'if') {
		$self->_line_error('missing condition') if $noargs;
		# add a new conditional frame state
		# if current frame is true, evaluate the expression, else mark
		# new frame as been true
		push(@$frames,$$stateh > 0 ? $self->_eval_bool($args) : -1);
	} elsif ($cmd eq 'elsif') {
		$self->_line_error('no if context') unless (@$frames > 1);
		$self->_line_error('missing condition') if $noargs;
		# evaluate new condition if frame state is false
		# if has been true, set to been true
		$$stateh = $$stateh ? -1 : $self->_eval_bool($args);
	} elsif ($cmd eq 'else') {
		$self->_line_error('no if context') unless (@$frames > 1);
		$self->_line_error("spurious input: $args") unless $noargs;
		# invert frame state from false to true if never been true
		$$stateh = $$stateh ? -1 : 1;
	} elsif ($cmd eq 'endif') {
		$self->_line_error('no if context') unless (@$frames > 1);
		$self->_line_error("spurious input: $args") unless $noargs;
		# remove the current frame
		pop(@$frames);
	} elsif ($$stateh > 0) {
		if ($cmd eq 'default') {
			my ($pat,@pairs) = split(' ',$self->expand_string_scalar($args));
			foreach (@pairs) {
				unless (/^(\S+)=(\S+)$/o) {
					$self->_line_error('default syntax error');
				}
				push(@{$self->{defaults}{$pat}},[$1,$2]);
			}
		} elsif ($cmd eq 'include') {
			foreach (split(' ',$self->expand_string_scalar($args))) {
				$self->read_bom($self->resolve_path($_));
			}
		} elsif ($cmd eq 'set') {
			# evaluate only if current frame is true
			unless ($args =~ /^($MacroRe)\s*=\s*(.*)$/o) {
				$self->_line_error('set syntax error');
			}
			$self->_dict_key($1,$self->expand_string_scalar($2));
		} elsif ($cmd eq 'die') {
			$self->_line_error('internal bom error');
		} else {
			$self->_line_error("unknown command: $cmd");
		}
	}

	();
}

sub resolve_path {
	my ($self,$path) = @_;
	(substr($path,0,1) eq '/') ? $path : $self->{filebase}.$path;
}

sub process_string {
	my ($self,$entries,$string) = @_;

	# line starts with non-whitespace, it's a path
	# else it's attr pairs

	foreach my $string ($self->expand_string($string)) {
		if ($string =~ /^\S/o) { # it's a path
			my $path = $string;
			# adjust path relative to bom file
			$path = $self->resolve_path($path);

			# flush the existing entries if the line number of
			# the last entry is not the previous line;  this
			# logic enables multiple paths followed by shared
			# attributes
			if (@$entries) {
				my $delta  = $self->{line} - $entries->[-1]{line};
				if ($delta > 1) {
					map { $self->add_entry($_) } @$entries;
					@$entries = ();
				}
			}

			# make a new entry
			push(@$entries,
				Bom::Entry->new($path,$self->{file},$self->{line})
			);
		} else { # it's attr pairs
			# make all entries parse the attributes
			map { $self->parse_attrs($_,$string) } @$entries;
		}
	}

	();
}

sub expand_string {
	my ($self,$string) = @_;

	do {} while $string =~ s{^(.*?) \$\( (.*?) \) (.*)$}{
		my ($pfx,$key,$sfx) = ($1,$2,$3);

		$self->_line_error("invalid macro: '$key'") unless (
			$key =~ /^$MacroRe$/o
		);

        my $line;
        foreach (split(' ',$self->_dict_key($key))) {
			$line .= $pfx.$_.$sfx."\n";
		}
        chomp($line);

        $line;
    }ximeo;

	split("\n",$string);
}

sub expand_string_scalar {
	my ($self,$string) = @_;
	join(' ',$self->expand_string($string));
}

# set/get the parser dictionary for macro resolution
sub dict {
	my $self = shift;
	if (@_) {
		my $props = shift;
		if (ref($props)) {
			$self->{dict} = Ref::copy($props);
		} else {
			my %dict;
			open(my $fh,'<',$props) || $self->error("open: $props: $!");
			while (<$fh>) {
				chomp;
				my ($k,$v) = split('=',$_,2);
				$dict{$k} = $v;
			}
			$self->{dict} = \%dict;
		}
		$self->{ldict} = undef;
	}
	$self->{dict};
}

sub ldict {
	my $self = shift;
	$self->{ldict} = Ref::copy(shift) if @_;
	$self->{ldict};
}

# lookup the given key in the parser dictionary
# FIXME: this is kind of nasty

sub dict_key {
	my $self = shift;
	$self->__dict_key(0,@_);
}
	
sub _dict_key {
	my $self = shift;
	$self->__dict_key(1,@_);
}

sub __dict_key {
	my ($self,$internal,$key) = @_;
	my $val;

	if (@_ > 3) {
		$val = $_[3];
		$self->_line_error('key already exists') if exists($self->{dict}{$key});
		$self->{ldict}{$key} = $val;
	} elsif ($self->{ldict} && exists($self->{ldict}{$key})) {
		$val = $self->{ldict}{$key};
	} elsif ($self->{dict} && exists($self->{dict}{$key})) {
		$val = $self->{dict}{$key};
	} elsif ($key !~ /^(DBG|TEST)_/o) {
		my $err = "undefined key: $key";
		$self->_line_error($err) if $internal;
	}

	$val;
}

# evaluate a boolean expression
sub _eval_bool {
	my ($self,$expr) = @_;

	my (@args,$arg,$in_quote);
	# break up the expression into an arg list
	# strip quotes around strings & expand macros
	foreach (split(' ',$expr)) {
		if ($in_quote) {
			$in_quote = !s/"$//o;
			$arg .= ' ' unless ($arg eq '');
			$arg .= $_;
		} elsif ($in_quote = s/^"//o) {
			$in_quote &&= !s/"$//o;
			$arg = $_;
		} elsif (/^$MacroRe/o) {
			$self->_line_error("invalid macro: $_") unless /^$MacroRe$/o;
			$arg = $self->_dict_key($_);
		} else {
			$arg = $_;
		}
		push(@args,$arg) unless $in_quote;
	}
	$self->_line_error('unclosed quote') if $in_quote;

	# execute the expr command
	my $pid = open(my $fh,'-|') || exec('expr',@args);
	while (<$fh>) {} # discard output
	close($fh);

	# bomb on error
	my $exit = $? >> 8;
	$self->_line_error("invalid expression: @args") if ($? && $exit != 1);

	# invert the exit code to get boolean
	!$exit;
}

sub parse_attrs {
	my ($self,$entry,$str) = @_;

	while ($str =~ /\G\s+ ([^\s=]+) (="(.*?)" | ='(.*?)' | =(\S*) | ())/xgo) {
		my ($key,$val) = ($1,substr($2,0,1) eq '=' ? $+ : undef);

		if (defined($entry->get_attr($key))) {
			$self->warn("duplicate attribute: $key",$entry);
		}
		$entry->set_attr($key,$val);
	}

	if (defined(pos($str))) {
		$self->error("cannot parse attributes: ".substr($str,pos($str)),$entry);
	}

	();
}

sub entry_index {
	my ($self,$entry) = @_;
	$entry->{path};
}

sub has_entry {
	my ($self,$entry) = @_;
	$self->get_entry($self->entry_index($entry));
}

sub add_entry {
	my ($self,$entry) = @_;

	my $ext = (fileparse($entry->path,qr{\..*?}))[2];
	foreach my $pat ($entry->attrpairs,$ext,'*') {
		if (my $list = $self->{defaults}{$pat}) {
			foreach (@$list) {
				my ($key,$val) = @$_;
				$entry->set_attr($key,$val) unless $entry->has_attr($key);
			}
		}
	}

	if (my $callback = $self->{callback}) {
		$self->$callback($entry);
	} else {
		$self->put_entry($self->entry_index($entry),$entry);
	}
	();
}

sub get_entry {
	my ($self,$key) = @_;
	$self->{entries}{$key};
}

sub put_entry {
	my ($self,$key,$entry) = @_;
	my $old_entry = $self->get_entry($key);

	if (!defined($old_entry)) {
		$self->{entries}{$key} = $entry;
	} else {
		$self->error("duplicate entry: $key",$entry,$old_entry);
	}
}

sub del_entry {
	my $self = shift;
	delete(@{$self->{entries}}{@_});
	();
}

sub all_entries { shift->{entries} }

sub grep_entries {
	my ($self,$re) = @_;
	my $entries = $self->all_entries;
	my %match_entries;

	if (my @matches = grep { $_ =~ $re } keys(%$entries)) {
		@match_entries{@matches} = @$entries{@matches};
	}

	keys(%match_entries) ? \%match_entries : undef;
}

sub grep_attrs {
	my ($self,$attr,$re) = @_;
	my $entries = $self->all_entries;
	my %match_entries;

	while (my ($key,$entry) = each(%$entries)) {
		my $match = defined($re)
			? $entry->get_attr($attr) =~ $re
			: $entry->has_attr($attr);
		if ($match) {
			$match_entries{$key} = $entry;
		}
	}

	keys(%match_entries) ? \%match_entries : undef;
}


sub merge_entries {
	my ($self,$entries) = @_;

	while (my ($k,$v) = each(%$entries)) {
		$self->put_entry($k,$v);
	}

	();
}

sub stringify_entries {
	my $self = shift;
	my $entries = ref($self) ? $self->all_entries : shift;

	my $dump;
	foreach (sort(keys(%$entries))) {
		$dump .= $entries->{$_}->stringify."\n";
	}
	chomp($dump);
	$dump;
}

sub stringify { shift->{string} }

sub _errmsg {
	my ($self,$fatal,$err,@entries) = @_;
	my $msg = "\nbom: ".($fatal ? 'error' : 'warning').": $err\n";

	my $where = join($msg,
		map {
			my $str;
			if (UNIVERSAL::can($_,'stringify')) {
				$str = "  location=$_->{file}:$_->{line}\n";
				(my $estr = $_->stringify) =~ s/^/   + /mgo;
				$str .= $estr;
			} else {
				($str = $_) =~ s/^/   + /mgo;
			}
			$str;
		} @entries
	);

	$msg .= "$where\n" if defined($where);
	$fatal ? die($msg) : warn($msg);
}

sub _line_error {
	my ($self,$err) = @_;
	$self->_errmsg(1,$err,$self);
}

sub _line_warn {
	my ($self,$err) = @_;
	$self->_errmsg(0,$err,$self);
}

sub error {
	shift->_errmsg(1,@_);
}

sub warn {
	shift->_errmsg(0,@_);
}

1;