projectcreator.pm

一个开源的网络开发库ACE

package ProjectCreator;

# ************************************************************
# Description   : Base class for all project creators
# Author        : Chad Elliott
# Create Date   : 3/13/2002
# ************************************************************

# ************************************************************
# Pragmas
# ************************************************************

use strict;
use FileHandle;
use File::Path;
use File::Basename;

use Creator;
use TemplateInputReader;
use TemplateParser;

use vars qw(@ISA);
@ISA = qw(Creator);

# ************************************************************
# Data Section
# ************************************************************

my($BaseClassExtension)      = "mpb";
my($ProjectCreatorExtension) = "mpc";
my($TemplateExtension)       = "mpd";
my($TemplateInputExtension)  = "mpt";

## Valid names for assignments within a project
my(%validNames) = ('exename'         => 1,
                   'sharedname'      => 1,
                   'staticname'      => 1,
                   'libpaths'        => 1,
                   'install'         => 1,
                   'includes'        => 1,
                   'idlflags'        => 1,
                   'idlpreprocessor' => 1,
                   'defaultlibs'     => 1,
                   'depends'         => 1,
                   'libs'            => 1,
                   'pch_header'      => 1,
                   'pch_source'      => 1,
                   'ssl'             => 1,
                   'tao'             => 1,
                   'dllout'          => 1,
                   'libout'          => 1,
                   'dllflags'        => 1,
                   'libflags'        => 1,
                   'version'         => 1,
                   'requires'        => 1,
                   'avoids'          => 1,
                   'compname'        => 1,
                   'comps'           => 1,
                   'tagname'         => 1,
                   'tagchecks'       => 1,
                   'include_dir'     => 1,
                   'core'            => 1,
                   'idlgendir'       => 1,
                  );

## Deal with these components in a special way
my(@specialComponents) = ('header_files', 'inline_files');

# ************************************************************
# 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($self)      = Creator::new($class, $global, $inc,
                                $template, $ti, $relative,
                                $addtemp, $addproj,
                                $progress, 'project');

  $self->{$self->{'type_check'}}   = 0;
  $self->{'global_assign'}         = {};
  $self->{'files_written'}         = [];
  $self->{'project_info'}          = [];
  $self->{'reading_global'}        = 0;
  $self->{'reading_parent'}        = [];
  $self->{'dexe_template_input'}   = undef;
  $self->{'lexe_template_input'}   = undef;
  $self->{'lib_template_input'}    = undef;
  $self->{'dll_template_input'}    = undef;
  $self->{'idl_defaulted'}         = 0;
  $self->{'source_defaulted'}      = 0;
  $self->{'writing_type'}          = 0;
  $self->{'want_dynamic_projects'} = $dynamic;
  $self->{'want_static_projects'}  = $static;
  $self->{'flag_overrides'}        = {};

  ## Set up the verbatim constructs
  $self->{'verbatim'} = {};

  ## Valid component names within a project along with the valid file extensions
  my(%vc) = ('source_files'        => [ "\\.cpp", "\\.cxx", "\\.cc", "\\.c", "\\.C", ],
             'template_files'      => [ "_T\\.cpp", "_T\\.cxx", "_T\\.cc", "_T\\.c", "_T\\.C", ],
             'header_files'        => [ "\\.h", "\\.hxx", "\\.hh", ],
             'inline_files'        => [ "\\.i", "\\.inl", ],
             'idl_files'           => [ "\\.idl", ],
             'documentation_files' => [ "README", "readme", "\\.doc", "\\.txt", ],
             'resource_files'      => [ "\\.rc", ],
            );

  ## Exclude these extensions when auto generating the component values
  my(%ec) = ('source_files' => [ "_T\\.cpp", "_T\\.cxx", "_T\\.cc", "_T\\.C", ],
            );

  ## Match up assignments with the valid components
  my(%ma) = ('source_files' => [ 'includes' ],
             'idl_files'    => [ 'idlgendir', 'idlflags' ],
            );
  $self->{'matching_assignments'} = \%ma;
  $self->{'valid_components'}     = \%vc;
  $self->{'exclude_components'}   = \%ec;
  $self->{'skeleton_endings'}     = [ 'C', 'S' ];

  ## Allow subclasses to override the default extensions
  $self->set_component_extensions();

  return $self;
}


sub read_global_configuration {
  my($self)   = shift;
  my($input)  = $self->get_global_cfg();
  my($status) = 1;

  if (defined $input) {
    $self->{'reading_global'} = 1;
    $status = $self->parse_file($input);
    $self->{'reading_global'} = 0;
  }

  return $status;
}


sub parse_line {
  my($self)   = shift;
  my($ih)     = shift;
  my($line)   = shift;
  my($type)   = $self->{'grammar_type'};
  my($status,
     $errorString,
     @values) = $self->parse_known($line);

  ## parse_known() passes back an array of values
  ## that make up the contents of the line parsed.
  ## The array can have 0 to 3 items.  The first,
  ## if defined, is always an identifier of some
  ## sort.

  if ($status && defined $values[0]) {
    if ($values[0] eq $type) {
      my($name)      = $values[1];
      my($typecheck) = $self->{'type_check'};
      if (defined $name && $name eq '}') {
        ## Project Ending
        my($rp) = $self->{'reading_parent'};
        if (!defined $$rp[0] && !$self->{'reading_global'}) {
          ## Fill in all the default values
          $self->generate_defaults();

          ## Perform any additions, subtractions
          ## or overrides for the project values.
          my($addproj) = $self->get_addproj();
          foreach my $ap (keys %$addproj) {
            if (defined $validNames{$ap}) {
              my($val) = $$addproj{$ap};
              if ($$val[0] > 0) {
                $self->process_assignment_add($ap, $$val[1]);
              }
              elsif ($$val[0] < 0) {
                $self->process_assignment_sub($ap, $$val[1]);
              }
              else {
                $self->process_assignment($ap, $$val[1]);
              }
            }
            else {
              $errorString = 'ERROR: Invalid ' .
                             "assignment modification name: $ap";
              $status = 0;
            }
          }

          if ($status) {
            ## End of project; Write out the file.
            $self->write_project();

            foreach my $key (keys %{$self->{'valid_components'}}) {
              delete $self->{$key};
            }
            $self->{'assign'}   = {};
            $self->{'verbatim'} = {};
          }
        }
        $self->{$typecheck}         = 0;
        $self->{'idl_defaulted'}    = 0;
        $self->{'flag_overrides'}   = {};
        $self->{'source_defaulted'} = 0;
      }
      else {
        ## Project Beginning
        ## Deal with the inheritance hiearchy first
        my($parents) = $values[2];
        if (defined $parents) {
          foreach my $parent (@$parents) {
            ## Read in the parent onto ourself
            my($file) = $self->search_include_path(
                                 "$parent.$BaseClassExtension");
            if (!defined $file) {
              $file = $self->search_include_path(
                                   "$parent.$ProjectCreatorExtension");
            }

            if (defined $file) {
              push(@{$self->{'reading_parent'}}, 1);
              $status = $self->parse_file($file);
              pop(@{$self->{'reading_parent'}});

              if (!$status) {
                $errorString = "ERROR: Invalid parent: $parent";
              }
            }
            else {
              $status = 0;
              $errorString = "ERROR: Unable to locate parent: $parent";
            }
          }
        }

        ## Set up some initial values
        if (defined $name) {
          $name =~ s/^\(\s*//;
          $name =~ s/\s*\)$//;
          $self->process_assignment('project_name', $name);
        }
        $self->{$typecheck} = 1;

        ## Copy each value from global_assign into assign
        if (!$self->{'reading_global'}) {
          foreach my $key (keys %{$self->{'global_assign'}}) {
            if (!defined $self->{'assign'}->{$key}) {
              $self->{'assign'}->{$key} = $self->{'global_assign'}->{$key};
            }
          }
        }
      }
    }
    elsif ($values[0] eq 'assignment') {
      my($name)  = $values[1];
      my($value) = $values[2];
      if (defined $validNames{$name}) {
        $self->process_assignment($name, $value);
      }
      else {
        $errorString = "ERROR: Invalid assignment name: $name";
        $status = 0;
      }
    }
    elsif ($values[0] eq 'assign_add') {
      my($name)  = $values[1];
      my($value) = $values[2];
      if (defined $validNames{$name}) {
        $self->process_assignment_add($name, $value);
      }
      else {
        $errorString = "ERROR: Invalid addition name: $name";
        $status = 0;
      }
    }
    elsif ($values[0] eq 'assign_sub') {
      my($name)  = $values[1];
      my($value) = $values[2];
      if (defined $validNames{$name}) {
        $self->process_assignment_sub($name, $value);
      }
      else {
        $errorString = "ERROR: Invalid subtraction name: $name";
        $status = 0;
      }
    }
    elsif ($values[0] eq 'component') {
      my($comp) = $values[1];
      my($name) = $values[2];
      if (defined $name) {
        $name =~ s/^\(\s*//;
        $name =~ s/\s*\)$//;
      }
      else {
        $name = 'default';
      }

      my($vc) = $self->{'valid_components'};
      if (defined $$vc{$comp}) {
        if (!$self->parse_components($ih, $comp, $name)) {
          $errorString = "ERROR: Unable to process $comp";
          $status = 0;
        }
      }
      else {
        if ($comp eq 'verbatim') {
          my($type, $loc) = split(/\s*,\s*/, $name);
          if (!$self->parse_verbatim($ih, $comp, $type, $loc)) {
            $errorString = "ERROR: Unable to process $comp";
            $status = 0;
          }
        }
        else {
          $errorString = "ERROR: Invalid component name: $comp";
          $status = 0;
        }
      }
    }
    else {
      $errorString = "ERROR: Unrecognized line: $line";
      $status = 0;
    }
  }
  elsif ($status == -1) {
    $status = 0;
  }

  return $status, $errorString;
}


sub parse_components {
  my($self)    = shift;
  my($fh)      = shift;
  my($tag)     = shift;
  my($name)    = shift;
  my($current) = '000_FILES';
  my($status)  = 1;
  my($names)   = {};
  my($comps)   = {};
  my($order)   = 0;
  my($set)     = 0;
  my(%flags)   = ();

  if (defined $self->{$tag}) {
    $names = $self->{$tag};
  }
  else {
    $self->{$tag} = $names;
  }
  if (defined $$names{$name}) {
    $comps = $$names{$name};
  }
  else {
    $$names{$name} = $comps;
  }
  if (!defined $$comps{$current}) {
    $$comps{$current} = [];
  }

  while(<$fh>) {
    my($line) = $self->strip_line($_);

    if ($line eq '') {
    }
    elsif ($line =~ /^(\w+)\s*{$/) {
      if (!defined $current || !$set) {
        if (defined $current && !defined $$comps{$current}->[0]) {
          ## The default components name was never used
          ## so we remove it from the components
          delete $$comps{$current};
        }
        $current = sprintf("%03d_$1", $order);
        $set = 1;
        $order++;
        if (!defined $$comps{$current}) {
          $$comps{$current} = [];
        }
      }
      else {
        $status = 0;
        last;
      }
    }
    elsif ($line =~ /^}/) {
      if (defined $current && $set) {
        $current = undef;
      }
      else {
        ## This is not an error,
        ## this is the end of the components
        last;
      }
    }
    elsif (defined $current) {
      my(@values) = ();
      ## If this returns true, then we've found an assignment
      if ($self->parse_assignment($line, \@values)) {
        my($over) = {};
        if (defined $self->{'flag_overrides'}->{$tag}) {
          $over = $self->{'flag_overrides'}->{$tag};
        }
        else {
          $self->{'flag_overrides'}->{$tag} = $over;
        }

        if ($values[0] eq 'assignment') {
          $self->process_assignment($values[1],
                                    $values[2], \%flags);
        }
        elsif ($values[0] eq 'assign_add') {
          $self->process_assignment_add($values[1],
                                        $values[2], \%flags);
        }
        elsif ($values[0] eq 'assign_sub') {
          $self->process_assignment_sub($values[1],
                                        $values[2], \%flags);
        }
      }
      else {
        my($over) = $self->{'flag_overrides'}->{$tag};
        if (defined $over) {
          $$over{$line} = \%flags;
        }
        my($array) = $$comps{$current};
        push(@$array, $line);
      }
    }
    else {
      $status = 0;
      last;
    }
  }

  return $status;
}


sub parse_verbatim {
  my($self)    = shift;
  my($fh)      = shift;
  my($tag)     = shift;
  my($type)    = shift;
  my($loc)     = shift;

  ## All types are lowercase
  $type = lc($type);

  if (!defined $self->{'verbatim'}->{$type}) {
    $self->{'verbatim'}->{$type} = {};
  }
  $self->{'verbatim'}->{$type}->{$loc} = [];
  my($array) = $self->{'verbatim'}->{$type}->{$loc};

  while(<$fh>) {
    my($line) = $self->strip_line($_);

    if ($line eq '') {
    }
    elsif ($line =~ /^}/) {
      ## This is not an error,
      ## this is the end of the components
      last;
    }
    else {
      push(@$array, $line);
    }
  }

  return 1;
}


sub process_assignment {
  my($self)   = shift;
  my($name)   = shift;
  my($value)  = shift;
  my($assign) = shift;
  my($tag)    = ($self->{'reading_global'} ? 'global_assign' : 'assign');

  ## If no hash table was passed in
  if (!defined $assign) {
    $assign = $self->{$tag};
  }

  ## If we haven't yet defined the hash table in this project
  if (!defined $assign) {
    $assign = {};
    $self->{$tag} = $assign;
  }

  if (defined $value) {
    $value =~ s/^\s+//;
    $value =~ s/\s+$//;

    if ($self->convert_slashes()) {
      $value = $self->slash_to_backslash($value);
    }
  }

  $$assign{$name} = $value;
}


sub process_assignment_add {
  my($self)   = shift;
  my($name)   = shift;
  my($value)  = shift;
  my($assign) = shift;