Rev 198 | Go to most recent revision | Blame | Last modification | View Log | RSS feed
package Creator;
# ************************************************************
# Description : Base class for workspace and project creators
# Author : Chad Elliott
# Create Date : 5/13/2002
# ************************************************************
# ************************************************************
# Pragmas
# ************************************************************
use strict;
use FileHandle;
use Parser;
use vars qw(@ISA);
@ISA = qw(Parser);
# ************************************************************
# Data Section
# ************************************************************
my($assign_key) = 'assign';
my($gassign_key) = 'global_assign';
my(@statekeys) = ('global', 'include', 'template', 'ti',
'dynamic', 'static', 'relative', 'addtemp',
'addproj', 'progress', 'toplevel', 'baseprojs',
'feature_file', 'features', 'hierarchy',
'name_modifier', 'apply_project', 'into', 'use_env',
'expand_vars', 'language',
);
my(%all_written) = ();
my($onVMS) = ($^O eq 'VMS');
# ************************************************************
# Subroutine Section
# ************************************************************
sub new {
my($class) = shift;
my($global) = shift;
my($inc) = shift;
my($template) = shift;
my($ti) = shift;
my($dynamic) = shift;
my($static) = shift;
my($relative) = shift;
my($addtemp) = shift;
my($addproj) = shift;
my($progress) = shift;
my($toplevel) = shift;
my($baseprojs) = shift;
my($feature) = shift;
my($features) = shift;
my($hierarchy) = shift;
my($nmodifier) = shift;
my($applypj) = shift;
my($into) = shift;
my($language) = shift;
my($use_env) = shift;
my($expandvars) = shift;
my($type) = shift;
my($self) = Parser::new($class, $inc);
$self->{'relative'} = $relative;
$self->{'template'} = $template;
$self->{'ti'} = $ti;
$self->{'global'} = $global;
$self->{'grammar_type'} = $type;
$self->{'type_check'} = $type . '_defined';
$self->{'global_read'} = 0;
$self->{'current_input'} = '';
$self->{'progress'} = $progress;
$self->{'addtemp'} = $addtemp;
$self->{'addproj'} = $addproj;
$self->{'toplevel'} = $toplevel;
$self->{'files_written'} = {};
$self->{'real_fwritten'} = [];
$self->{'reading_global'} = 0;
$self->{$gassign_key} = {};
$self->{$assign_key} = {};
$self->{'baseprojs'} = $baseprojs;
$self->{'dynamic'} = $dynamic;
$self->{'static'} = $static;
$self->{'feature_file'} = $feature;
$self->{'features'} = $features;
$self->{'hierarchy'} = $hierarchy;
$self->{'name_modifier'} = $nmodifier;
$self->{'apply_project'} = $applypj;
$self->{'into'} = $into;
$self->{'language'} = $language;
$self->{'use_env'} = $use_env;
$self->{'expand_vars'} = $expandvars;
$self->{'convert_slashes'} = $self->convert_slashes();
$self->{'case_tolerant'} = $self->case_insensitive();
return $self;
}
sub preprocess_line {
my($self) = shift;
my($fh) = shift;
my($line) = shift;
$line = $self->strip_line($line);
while ($line =~ /\\$/) {
$line =~ s/\s*\\$/ /;
my($next) = $fh->getline();
if (defined $next) {
$line .= $self->strip_line($next);
}
}
return $line;
}
sub generate_default_input {
my($self) = shift;
my($status,
$error) = $self->parse_line(undef, "$self->{'grammar_type'} {");
if ($status) {
($status, $error) = $self->parse_line(undef, '}');
}
if (!$status) {
$self->error($error);
}
return $status;
}
sub parse_file {
my($self) = shift;
my($input) = shift;
my($oline) = $self->get_line_number();
## Read the input file and get the last line number
my($status, $errorString) = $self->read_file($input);
if (!$status) {
$self->error($errorString,
"$input: line " . $self->get_line_number() . ':');
}
elsif ($status && $self->{$self->{'type_check'}}) {
## If we are at the end of the file and the type we are looking at
## is still defined, then we have an error
$self->error("Did not " .
"find the end of the $self->{'grammar_type'}",
"$input: line " . $self->get_line_number() . ':');
$status = 0;
}
$self->set_line_number($oline);
return $status;
}
sub generate {
my($self) = shift;
my($input) = shift;
my($status) = 1;
## Reset the files_written hash array between processing each file
$self->{'files_written'} = {};
$self->{'real_fwritten'} = [];
## Allow subclasses to reset values before
## each call to generate().
$self->reset_values();
## Read the global configuration file
if (!$self->{'global_read'}) {
$status = $self->read_global_configuration();
$self->{'global_read'} = 1;
}
if ($status) {
$self->{'current_input'} = $input;
## An empty input file name says that we
## should generate a default input file and use that
if ($input eq '') {
$status = $self->generate_default_input();
}
else {
$status = $self->parse_file($input);
}
}
return $status;
}
sub parse_assignment {
my($self) = shift;
my($line) = shift;
my($values) = shift;
if ($line =~ /^(\w+(::\w+)*)\s*([\-+]?=)\s*(.*)?/) {
push(@$values, $3, lc($1), $4);
return 1;
}
return 0;
}
sub parse_known {
my($self) = shift;
my($line) = shift;
my($status) = 1;
my($errorString) = undef;
my($type) = $self->{'grammar_type'};
my(@values) = ();
##
## Each regexp that looks for the '{' looks for it at the
## end of the line. It is purposely this way to decrease
## the amount of extra lines in each file. This
## allows for the most compact file as human readably
## possible.
##
if ($line eq '') {
}
elsif ($line =~ /^$type\s*(\([^\)]+\))?\s*(:.*)?\s*{$/) {
my($name) = $1;
my($parents) = $2;
if ($self->{$self->{'type_check'}}) {
$errorString = "Did not find the end of the $type";
$status = 0;
}
else {
if (defined $parents) {
$parents =~ s/^:\s*//;
$parents =~ s/\s+$//;
my(@parents) = split(/\s*,\s*/, $parents);
if (!defined $parents[0]) {
## The : was used, but no parents followed. This
## is an error.
$errorString = 'No parents listed';
$status = 0;
}
$parents = \@parents;
}
push(@values, $type, $name, $parents);
}
}
elsif ($line =~ /^}$/) {
if ($self->{$self->{'type_check'}}) {
push(@values, $type, $line);
}
else {
$errorString = "Did not find the beginning of the $type";
$status = 0;
}
}
elsif ($line =~ /^(feature)\s*\(([^\)]+)\)\s*(:.*)?\s*{$/) {
my($type) = $1;
my($name) = $2;
my($parents) = $3;
my(@names) = split(/\s*,\s*/, $name);
if (defined $parents) {
$parents =~ s/^:\s*//;
$parents =~ s/\s+$//;
my(@parents) = split(/\s*,\s*/, $parents);
if (!defined $parents[0]) {
## The : was used, but no parents followed. This
## is an error.
$errorString = 'No parents listed';
$status = 0;
}
$parents = \@parents;
}
push(@values, $type, \@names, $parents);
}
elsif (!$self->{$self->{'type_check'}}) {
$errorString = "No $type was defined";
$status = 0;
}
elsif ($self->parse_assignment($line, \@values)) {
## If this returns true, then we've found an assignment
}
elsif ($line =~ /^(\w+)\s*(\([^\)]+\))?\s*{$/) {
my($comp) = lc($1);
my($name) = $2;
if (defined $name) {
$name =~ s/^\(\s*//;
$name =~ s/\s*\)$//;
}
else {
$name = $self->get_default_component_name();
}
push(@values, 'component', $comp, $name);
}
else {
$errorString = "Unrecognized line: $line";
$status = -1;
}
return $status, $errorString, @values;
}
sub parse_scope {
my($self) = shift;
my($fh) = shift;
my($name) = shift;
my($type) = shift;
my($validNames) = shift;
my($flags) = shift;
my($elseflags) = shift;
my($status) = 0;
my($errorString) = "Unable to process $name";
if (!defined $flags) {
$flags = {};
}
while(<$fh>) {
my($line) = $self->preprocess_line($fh, $_);
if ($line eq '') {
}
elsif ($line =~ /^}$/) {
($status, $errorString) = $self->handle_scoped_end($type, $flags);
last;
}
elsif ($line =~ /^}\s*else\s*{$/) {
if (defined $elseflags) {
## From here on out anything after this goes into the $elseflags
$flags = $elseflags;
$elseflags = undef;
## We need to adjust the type also. If there was a type
## then the first part of the clause was used. If there was
## no type, then the first part was ignored and the second
## part will be used.
if (defined $type) {
$type = undef;
}
else {
$type = $self->get_default_component_name();
}
}
else {
$status = 0;
$errorString = 'An else is not allowed in this context';
last;
}
}
else {
my(@values) = ();
if (defined $validNames && $self->parse_assignment($line, \@values)) {
if (defined $$validNames{$values[1]}) {
if ($values[0] eq '=') {
$self->process_assignment($values[1], $values[2], $flags);
}
elsif ($values[0] eq '+=') {
$self->process_assignment_add($values[1], $values[2], $flags);
}
elsif ($values[0] eq '-=') {
$self->process_assignment_sub($values[1], $values[2], $flags);
}
}
else {
($status,
$errorString) = $self->handle_unknown_assignment($type,
@values);
if (!$status) {
last;
}
}
}
else {
($status, $errorString) = $self->handle_scoped_unknown($fh,
$type,
$flags,
$line);
if (!$status) {
last;
}
}
}
}
return $status, $errorString;
}
sub base_directory {
my($self) = shift;
return $self->mpc_basename($self->getcwd());
}
sub generate_default_file_list {
my($self) = shift;
my($dir) = shift;
my($exclude) = shift;
my($fileexc) = shift;
my($recurse) = shift;
my($dh) = new FileHandle();
my(@files) = ();
if (opendir($dh, $dir)) {
my($need_dir) = ($dir ne '.');
my($skip) = 0;
foreach my $file (grep(!/^\.\.?$/, readdir($dh))) {
$file =~ s/\.dir$// if ($onVMS);
## Prefix each file name with the directory only if it's not '.'
my($full) = ($need_dir ? "$dir/" : '') . $file;
if (defined $$exclude[0]) {
foreach my $exc (@$exclude) {
if ($full eq $exc) {
$skip = 1;
last;
}
}
}
if ($skip) {
$skip = 0;
$$fileexc = 1 if (defined $fileexc);
}
else {
if ($recurse && -d $full) {
push(@files,
$self->generate_default_file_list($full, $exclude,
$fileexc, $recurse));
}
else {
push(@files, $full);
}
}
}
if ($self->sort_files()) {
@files = sort { $self->file_sorter($a, $b) } @files;
}
closedir($dh);
}
return @files;
}
sub transform_file_name {
my($self) = shift;
my($name) = shift;
$name =~ s/[\s\-]/_/g;
return $name;
}
sub file_written {
my($self) = shift;
my($file) = shift;
return (defined $all_written{$self->getcwd() . '/' . $file});
}
sub add_file_written {
my($self) = shift;
my($file) = shift;
my($key) = lc($file);
if (defined $self->{'files_written'}->{$key}) {
$self->warning("$self->{'grammar_type'} $file " .
($self->{'case_tolerant'} ?
"has been overwritten." :
"of differing case has been processed."));
}
else {
$self->{'files_written'}->{$key} = $file;
push(@{$self->{'real_fwritten'}}, $file);
}
$all_written{$self->getcwd() . '/' . $file} = 1;
}
sub extension_recursive_input_list {
my($self) = shift;
my($dir) = shift;
my($exclude) = shift;
my($ext) = shift;
my($fh) = new FileHandle();
my(@files) = ();
if (opendir($fh, $dir)) {
foreach my $file (grep(!/^\.\.?$/, readdir($fh))) {
$file =~ s/\.dir$// if ($onVMS);
my($skip) = 0;
my($full) = ($dir ne '.' ? "$dir/" : '') . $file;
## Check for command line exclusions
if (defined $$exclude[0]) {
foreach my $exc (@$exclude) {
if ($full eq $exc) {
$skip = 1;
last;
}
}
}
## If we are not skipping this directory or file, then check it out
if (!$skip) {
if (-d $full) {
push(@files, $self->extension_recursive_input_list($full,
$exclude,
$ext));
}
elsif ($full =~ /$ext$/) {
push(@files, $full);
}
}
}
closedir($fh);
}
return @files;
}
sub modify_assignment_value {
my($self) = shift;
my($name) = shift;
my($value) = shift;
if ($self->{'convert_slashes'} && index($name, 'flags') == -1) {
$value =~ s/\//\\/g;
}
return $value;
}
sub get_assignment_hash {
## NOTE: If anything in this block changes, then you must make the
## same change in process_assignment.
my($self) = shift;
return $self->{$self->{'reading_global'} ? $gassign_key : $assign_key};
}
sub process_assignment {
my($self) = shift;
my($name) = shift;
my($value) = shift;
my($assign) = shift;
## If no hash table was passed in
if (!defined $assign) {
## NOTE: If anything in this block changes, then you must make the
## same change in get_assignment_hash.
$assign = $self->{$self->{'reading_global'} ?
$gassign_key : $assign_key};
}
if (defined $value) {
$value =~ s/^\s+//;
$value =~ s/\s+$//;
## Modify the assignment value before saving it
$$assign{$name} = $self->modify_assignment_value($name, $value);
}
else {
$$assign{$name} = undef;
}
}
sub process_assignment_add {
my($self) = shift;
my($name) = shift;
my($value) = shift;
my($assign) = shift;
my($nval) = $self->get_assignment_for_modification($name, $assign);
## Remove all duplicate parts from the value to be added.
## Whether anything gets removed or not is up to the implementation
## of the sub classes.
$value = $self->remove_duplicate_addition($name, $value, $nval);
## If there is anything to add, then do so
if ($value ne '') {
if (defined $nval) {
if ($self->preserve_assignment_order($name)) {
$nval .= " $value";
}
else {
$nval = "$value $nval";
}
}
else {
$nval = $value;
}
$self->process_assignment($name, $nval, $assign);
}
}
sub process_assignment_sub {
my($self) = shift;
my($name) = shift;
my($value) = shift;
my($assign) = shift;
my($nval) = $self->get_assignment_for_modification($name, $assign);
if (defined $nval) {
## Remove double quotes if there are any
$value =~ s/^\"(.*)\"$/$1/;
## Escape any regular expression special characters
$value = $self->escape_regex_special($value);
my($last) = 1;
my($found) = undef;
for(my $i = 0; $i <= $last; $i++) {
if ($i == $last) {
## If we did not find the string to subtract in the original
## value, try again after expanding template variables for
## subtraction.
$nval = $self->get_assignment_for_modification($name, $assign, 1);
}
for(my $j = 0; $j <= $last; $j++) {
## If we didn't find it the first time, try again with quotes
my($re) = ($j == $last ? '"' . $value . '"' : $value);
## Due to the way process_assignment() works, we only need to
## attempt to remove a value that is either followed by a space
## or at the end of the line (single values are always at the end
## of the line).
if ($nval =~ s/$re\s+// || $nval =~ s/$re$//) {
$self->process_assignment($name, $nval, $assign);
$found = 1;
last;
}
}
last if ($found);
}
}
}
sub fill_type_name {
my($self) = shift;
my($names) = shift;
my($def) = shift;
my($array) = ($names =~ /\s/ ? $self->create_array($names) : [$names]);
$names = '';
foreach my $name (@$array) {
if ($name =~ /\*/) {
my($pre) = $def . '_';
my($mid) = '_' . $def . '_';
my($post) = '_' . $def;
## Replace the beginning and end first then the middle
$name =~ s/^\*/$pre/;
$name =~ s/\*$/$post/;
$name =~ s/\*/$mid/g;
## Remove any trailing underscore or any underscore that is followed
## by a space. This value could be a space separated list.
$name =~ s/_$//;
$name =~ s/_\s/ /g;
$name =~ s/\s_/ /g;
## If any one word is capitalized then capitalize each word
if ($name =~ /[A-Z][0-9a-z_]+/) {
## Do the first word
if ($name =~ /^([a-z])([^_]+)/) {
my($first) = uc($1);
my($rest) = $2;
$name =~ s/^[a-z][^_]+/$first$rest/;
}
## Do subsequent words
while($name =~ /(_[a-z])([^_]+)/) {
my($first) = uc($1);
my($rest) = $2;
$name =~ s/_[a-z][^_]+/$first$rest/;
}
}
}
$names .= $name . ' ';
}
$names =~ s/\s+$//;
return $names;
}
sub save_state {
my($self) = shift;
my($selected) = shift;
my(%state) = ();
## Make a deep copy of each state value. That way our array
## references and hash references do not get accidentally modified.
foreach my $skey (defined $selected ? $selected : @statekeys) {
if (defined $self->{$skey}) {
if (UNIVERSAL::isa($self->{$skey}, 'ARRAY')) {
$state{$skey} = [];
foreach my $element (@{$self->{$skey}}) {
push(@{$state{$skey}}, $element);
}
}
elsif (UNIVERSAL::isa($self->{$skey}, 'HASH')) {
$state{$skey} = {};
foreach my $key (keys %{$self->{$skey}}) {
$state{$skey}->{$key} = $self->{$skey}->{$key};
}
}
else {
$state{$skey} = $self->{$skey};
}
}
}
return %state;
}
sub restore_state {
my($self) = shift;
my($state) = shift;
my($selected) = shift;
## Make a deep copy of each state value. That way our array
## references and hash references do not get accidentally modified.
foreach my $skey (defined $selected ? $selected : @statekeys) {
if (defined $state->{$skey}) {
if (UNIVERSAL::isa($state->{$skey}, 'ARRAY')) {
my(@arr) = @{$state->{$skey}};
$self->{$skey} = \@arr;
}
elsif (UNIVERSAL::isa($state->{$skey}, 'HASH')) {
my(%hash) = %{$state->{$skey}};
$self->{$skey} = \%hash;
}
else {
$self->{$skey} = $state->{$skey};
}
}
}
}
sub get_global_cfg {
my($self) = shift;
return $self->{'global'};
}
sub get_template_override {
my($self) = shift;
return $self->{'template'};
}
sub get_ti_override {
my($self) = shift;
return $self->{'ti'};
}
sub get_relative {
my($self) = shift;
return $self->{'relative'};
}
sub get_progress_callback {
my($self) = shift;
return $self->{'progress'};
}
sub get_addtemp {
my($self) = shift;
return $self->{'addtemp'};
}
sub get_addproj {
my($self) = shift;
return $self->{'addproj'};
}
sub get_toplevel {
my($self) = shift;
return $self->{'toplevel'};
}
sub get_into {
my($self) = shift;
return $self->{'into'};
}
sub get_use_env {
my($self) = shift;
return $self->{'use_env'};
}
sub get_expand_vars {
my($self) = shift;
return $self->{'expand_vars'};
}
sub get_files_written {
my($self) = shift;
return $self->{'real_fwritten'};
}
sub get_assignment {
my($self) = shift;
my($name) = shift;
my($assign) = shift;
## If no hash table was passed in
if (!defined $assign) {
$assign = $self->{$self->{'reading_global'} ?
$gassign_key : $assign_key};
}
return $$assign{$name};
}
sub get_assignment_for_modification {
my($self) = shift;
my($name) = shift;
my($assign) = shift;
my($subtraction) = shift;
return $self->get_assignment($name, $assign);
}
sub get_baseprojs {
my($self) = shift;
return $self->{'baseprojs'};
}
sub get_dynamic {
my($self) = shift;
return $self->{'dynamic'};
}
sub get_static {
my($self) = shift;
return $self->{'static'};
}
sub get_default_component_name {
#my($self) = shift;
return 'default';
}
sub get_hierarchy {
my($self) = shift;
return $self->{'hierarchy'};
}
sub get_name_modifier {
my($self) = shift;
return $self->{'name_modifier'};
}
sub get_apply_project {
my($self) = shift;
return $self->{'apply_project'};
}
sub get_language {
my($self) = shift;
return $self->{'language'};
}
sub get_outdir {
my($self) = shift;
if (defined $self->{'into'}) {
my($outdir) = $self->getcwd();
my($re) = $self->escape_regex_special($self->getstartdir());
$outdir =~ s/^$re//;
return $self->{'into'} . $outdir;
}
else {
return '.';
}
}
# ************************************************************
# Virtual Methods To Be Overridden
# ************************************************************
sub preserve_assignment_order {
#my($self) = shift;
#my($name) = shift;
return 1;
}
sub compare_output {
#my($self) = shift;
return 0;
}
sub handle_scoped_end {
#my($self) = shift;
#my($type) = shift;
#my($flags) = shift;
return 1, undef;
}
sub handle_unknown_assignment {
my($self) = shift;
my($type) = shift;
my(@values) = @_;
return 0, "Invalid assignment name: $values[1]";
}
sub handle_scoped_unknown {
my($self) = shift;
my($fh) = shift;
my($type) = shift;
my($flags) = shift;
my($line) = shift;
return 0, "Unrecognized line: $line";
}
sub remove_duplicate_addition {
my($self) = shift;
my($name) = shift;
my($value) = shift;
my($current) = shift;
return $value;
}
sub generate_recursive_input_list {
#my($self) = shift;
#my($dir) = shift;
#my($exclude) = shift;
return ();
}
sub reset_values {
#my($self) = shift;
}
sub sort_files {
#my($self) = shift;
return 1;
}
sub file_sorter {
#my($self) = shift;
#my($left) = shift;
#my($right) = shift;
return $_[1] cmp $_[2];
}
sub read_global_configuration {
#my($self) = shift;
#my($input) = shift;
return 1;
}
1;