creator.pm

这是广泛使用的通信开源项目,对于大容量,高并发的通讯要求完全能够胜任,他广泛可用于网络游戏医学图像网关的高qos要求.更详细的内容可阅读相应的材料

sub add_file_written {
  my($self) = shift;
  my($file) = shift;

  foreach my $written (@{$self->{'files_written'}}) {
    if ($written eq $file) {
      print "WARNING: $file has been overwritten by a " .
            "$self->{'grammar_type'} with a duplicate name.\n";
      last;
    }
    elsif (lc($written) eq lc($file)) {
      print "WARNING: $file has been overwritten by a " .
            "$self->{'grammar_type'} with different casing: $written.\n";
      last;
    }
  }
  push(@{$self->{'files_written'}}, $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))) {
      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($value) = shift;

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


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) {
    my($tag) = ($self->{'reading_global'} ? 'global_assign' : '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+$//;

    ## Modify the assignment value before saving it
    $$assign{$name} = $self->modify_assignment_value($value);
  }
  else {
    $$assign{$name} = undef;
  }
}


sub process_assignment_add {
  my($self)   = shift;
  my($name)   = shift;
  my($value)  = shift;
  my($assign) = shift;
  my($order)  = shift;
  my($nval)   = $self->get_assignment($name, $assign);

  if (defined $nval) {
    if ($order) {
      $nval .= " $value";
    }
    else {
      $nval = "$value $nval";
    }
  }
  else {
    $nval = $value;
  }
  $self->process_assignment($name, $nval, $assign);
  $self->process_duplicate_modification($name, $assign);
}


sub process_assignment_sub {
  my($self)   = shift;
  my($name)   = shift;
  my($value)  = shift;
  my($assign) = shift;
  my($nval)   = $self->get_assignment($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);

    if ($nval =~ /$value/) {
      ## Search for the first occurrence and remove it
      $nval =~ s/$value//;

      ## Reset the value
      $self->process_assignment($name, $nval, $assign);
    }
  }
}


sub fill_type_name {
  my($self) = shift;
  my($name) = shift;
  my($def)  = shift;

  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/;
      }
    }
  }

  return $name;
}


sub save_state {
  my($self)  = 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 (@statekeys) {
    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;

  ## Make a deep copy of each state value.  That way our array
  ## references and hash references do not get accidentally modified.
  foreach my $skey (@statekeys) {
    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_current_input {
  my($self) = shift;
  return $self->{'current_input'};
}


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_files_written {
  my($self) = shift;
  return $self->{'files_written'};
}


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

  ## If no hash table was passed in
  if (!defined $assign) {
    my($tag) = ($self->{'reading_global'} ? 'global_assign' : 'assign');
    $assign = $self->{$tag};
  }

  return $$assign{$name};
}


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'};
}

# ************************************************************
# Virtual Methods To Be Overridden
# ************************************************************

sub compare_output {
  #my($self) = shift;
  return 0;
}


sub handle_scoped_end {
  #my($self)  = shift;
  #my($type)  = shift;
  #my($flags) = shift;
}


sub handle_scoped_unknown {
  my($self)  = shift;
  my($fh)    = shift;
  my($type)  = shift;
  my($flags) = shift;
  my($line)  = shift;
  return 0, "ERROR: Unrecognized line: $line";
}


sub process_duplicate_modification {
  #my($self)   = shift;
  #my($name)   = shift;
  #my($assign) = shift;
}

sub generate_recursive_input_list {
  #my($self) = shift;
  #my($dir)  = shift;
  return ();
}


sub crlf {
  #my($self) = shift;
  return "\n";
}


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 $left cmp $right;
}


sub read_global_configuration {
  #my($self)  = shift;
  #my($input) = shift;
  return 1;
}


1;