[OpenSPARC-T2-DV] / tools / perlmod / DiagList / 1.11 / lib / site_perl / 5.8.0 / DiagList / Objects.pm

# ========== Copyright Header Begin ==========================================
# 
# OpenSPARC T2 Processor File: Objects.pm
# Copyright (C) 1995-2007 Sun Microsystems, Inc. All Rights Reserved
# 4150 Network Circle, Santa Clara, California 95054, U.S.A.
#
# * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER. 
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
# For the avoidance of doubt, and except that if any non-GPL license 
# choice is available it will apply instead, Sun elects to use only 
# the General Public License version 2 (GPLv2) at this time for any 
# software where a choice of GPL license versions is made 
# available with the language indicating that GPLv2 or any later version 
# may be used, or where a choice of which version of the GPL is applied is 
# otherwise unspecified. 
#
# Please contact Sun Microsystems, Inc., 4150 Network Circle, Santa Clara, 
# CA 95054 USA or visit www.sun.com if you need additional information or 
# have any questions. 
# 
# ========== Copyright Header End ============================================
package DiagList::Objects;

use strict;
use DiagList::Output;
use DiagList::Settings;

###############################################################################

{
  package DiagList;

  use DiagList::Output;
  use DiagList::Settings;

  use fields qw(
		file
		buildtags
		groups
	       );

  our $COMMENT_RE = qr|\/\/|;
  our $TAG_RE     =
  qr|^
  \s*
  \<
     \s*
     (\S+)
     \s*
     (.*)
  \>
  |x;

  #############################################################################

  sub new {
    my $class = shift;
    my $file  = shift;
    my $fh    = shift;

    my $this = {};
    bless $this, $class;

    tie my %buildtags, 'Tie::IxHash';
    $this->{buildtags} = \%buildtags;
    tie my %groups, 'Tie::IxHash';
    $this->{groups}    = \%groups;
    $this->parse($file, $fh) if defined $file;
    return $this;
  }

  #############################################################################

  sub parse {
    my $this = shift;
    my $file = shift;
    my $fh   = shift;

    chat "Reading $file";
    $this->{file} = $file;

    if(defined $fh and not (ref $fh and $fh->isa('IO::File'))) {
      my $handle = $fh;
      $fh = IO::File->new();
      $fh->fdopen(fileno($handle), "r") or
	fatal "Cannot create IO::File object from handle $handle\n";
    } else {
      $fh = IO::File->new("<$file") or fatal "Cannot open $file: $!";
    }

    my $line = 0;

    my $cur_build_tag;
    my $cur_name_tag;

    my @group_stack;
    my %group_args;
    my @runarg_stack;
    my @owner_stack;

    while(<$fh>) {
      $line++;
      chomp;
      s/$COMMENT_RE.*//;
      next unless /\S/;


      if(/^\#\s*(\d+)\s*\"(.*)\"/) {
	$line = $1 - 1;
	$file = $2;
	next;
      }

      if(/$TAG_RE/) {
	my ($tag, $args) = ($1, $2);

	if($tag =~ s|^\/||) {
	  # End tag

	  if($tag eq 'runargs') {
	    fatal "Nesting error, </runargs> with no matching beginning",
	      $file, $line unless @runarg_stack;
	    pop @runarg_stack;
	  } elsif($tag eq 'debugowner') {
	    fatal "Nesting error, </debugowners> with no matching beginning",
	      $file, $line unless @owner_stack;
	    pop @owner_stack;
	  } else {
	    my $group = pop @group_stack;
	    fatal "Nesting error: /$tag found, /$group->{name} expected",
	      $file, $line unless $tag eq $group->{name};

	    undef $cur_build_tag if $group->compile_tag;
	    undef $cur_name_tag  if $group->name_tag;
	    delete $group_args{$group->{name}};
	  }

	} else {

	  if($tag eq 'runargs') {
	    push @runarg_stack, $args;
	  } elsif($tag eq 'debugowner') {
	    push @owner_stack, $args;
	  } else {

	    # Start tag
	    my $buildtag = ($args =~ /\bsys=(\S+)/);
	    $buildtag = $1 if $buildtag;

	    my $nametag  = ($args =~ s/\bname=(\S+)\s*//);
	    $nametag  = $1 if $nametag;

	    # Error checking here
	    fatal "Build tag $tag multiply defined." , $file, $line
	      if exists $this->{buildtags}{$tag};


	    if($buildtag) {
	      chat "Inserting tags: $tag=$buildtag\n";

	      (my $buildargs = $args) =~ s/\b(sys=\S+)/-$1/;
	
	      $this->{buildtags}{$tag} = $buildargs;

	      # Strip sys= argument for use in group args
	      $args =~ s/\bsys=(\S)+\s*//;

	      $cur_build_tag = $tag;

	    }
	    if($nametag) {
	      fatal "Nametag $nametag defined within nametag $cur_name_tag",
		$file, $line if defined $cur_name_tag;
	      $cur_name_tag  = $nametag;
	    }


	    my $group;
	    if(exists $this->{groups}{$tag}) {
	      fatal "Group $tag is nested inside itself", $file, $line
		if exists $group_args{$tag};
	
	      $group = $this->{groups}{$tag};
	    } else {
	
	      $group = DiagList::Group->new(name => $tag);
	      $group->compile_tag($buildtag) if $buildtag;
	      $group->name_tag($nametag)     if $nametag;
	
	
	      $this->{groups}{$group->{name}} = $group;
	    }
	    $args =~ s/^\s+//;
	    $args =~ s/\s+$//;
	    $group_args{$group->{name}} = $args;
	    push @group_stack, $group;
	  }
	}
      } else {
	# Diag

	my $diag = DiagList::Diag->new_from_line($_, $cur_name_tag);

	fatal "Diag $diag->{alias} appears outside any group.", $file, $line
	  unless @group_stack;
	fatal "Diag $diag->{alias} appears outside any name tag.", $file, $line
	  unless defined $cur_name_tag;
	fatal "Diag $diag->{name} appears outside any build tag.", $file, $line
	  unless defined $cur_build_tag;

	foreach my $group (@group_stack) {
	  my $group_diag = $diag->new(); # Clone diag object
	  $group_diag->prepend_args([@runarg_stack,
				     $group_args{$group->{name}}]);
	  $group_diag->set_group($group->{name});
	  $group->add_diag($group_diag, $cur_build_tag);
	  if(@owner_stack) {
	    my $owner = $owner_stack[$#owner_stack];
	    $group_diag->add_owner($owner) unless
	      defined $group_diag->get_owner(); # diag has owner on cmdline
	  }
	}

      }

    }

    fatal "End of file with <runargs> still open!" if @runarg_stack;

    undef $fh;
  }

  #############################################################################

  sub build_hash {
    my $this = shift;
    return $this->{buildtags};
  }

  #############################################################################

  sub build_list {
    my $this = shift;
    return keys %{$this->{buildtags}};
  }

  #############################################################################

  sub build_args {
    my $this = shift;
    my $build_tag = shift;
    return unless exists $this->{buildtags}{$build_tag};
    return $this->{buildtags}{$build_tag};
  }

  #############################################################################

  sub group_hash {
    my $this = shift;
    return $this->{groups};
  }

  #############################################################################

  sub group_list {
    my $this = shift;
    return keys %{$this->{groups}};
  }

  #############################################################################

  sub find_group {
    my $this = shift;
    my $group = shift;

    return unless exists $this->{groups}{$group};
    return $this->{groups}{$group};
  }

  #############################################################################

}

###############################################################################
##############################################################################

{
  package DiagList::Group;
  use strict;

  use DiagList::Settings;

  use fields qw(
		name
		compile_tag
		name_tag

		tags
		);

  ############################################################################

  sub new {
    my $this = shift;
    my %args = @_;

    unless (ref $this) {
      $this = fields::new($this);
    }

    foreach my $arg (keys %args) {
      $this->{$arg} = $args{$arg};
    }
    $this->{tags}  = {} unless defined $this->{tags};

    return $this;
  }

  ############################################################################

  sub name {
    my $this = shift;
    my $name = shift;
    $this->{name} = $name if defined $name;
    return $this->{name};
  }

  ############################################################################

  sub compile_tag {
    my $this = shift;
    my $tag  = shift;

    $this->{compile_tag} = undef unless exists $this->{compile_tag};
    $this->{compile_tag} = $tag if defined $tag;
    return $this->{compile_tag};
  }

  ############################################################################

  sub name_tag {
    my $this = shift;
    my $tag  = shift;

    $this->{name_tag} = undef unless exists $this->{name_tag};
    $this->{name_tag} = $tag if defined $tag;
    return $this->{name_tag};
  }

  ############################################################################

  sub build_tags {
    my $this = shift;
    my $name = shift;
    return keys %{$this->{tags}};
  }

  ############################################################################

  sub list_diags {
    my $this     = shift;
    my $buildtag = shift;

    return unless exists $this->{tags}{$buildtag};
    return keys %{$this->{tags}{$buildtag}};
  }

  ############################################################################

  sub diag_hash {
    my $this     = shift;
    my $buildtag = shift;
    return unless exists $this->{tags}{$buildtag};
    return $this->{tags}{$buildtag};
  }

  ############################################################################

  sub find_diag {
    my $this     = shift;
    my $buildtag = shift;
    my $diagname = shift;

    return unless exists $this->{tags}{$buildtag};
    return unless exists $this->{tags}{$buildtag}{$diagname};
    return $this->{tags}{$buildtag}{$diagname};
  }

  ############################################################################

  sub add_diag {
    my $this   = shift;
    my $diag   = shift;
    my $buildtag   = shift;

    if(not defined $this->{tags}{$buildtag}) {
      tie my %sys, 'Tie::IxHash';
      $this->{tags}{$buildtag} = \%sys;
    }

    my $key = $diag->{name};
    my $gname = $this->{name};

    warn "WARNING: Diag $key multiply defined in group $gname\n"
      if (exists $this->{tags}{$buildtag}{$key} and display_warnings());

    $this->{tags}{$buildtag}{$key} = $diag;

  }

  ############################################################################
}

##############################################################################

{
  package DiagList::Diag;
  use strict;

  use Text::ParseWords;

  use fields qw(
		name
		alias
		files
		args

		nametag
		buildtag
		group
		debugowner
		);

  our @FILE_SUFFIXES = qw(s pal vr tpt);
		
  ############################################################################

  sub new {
    my $this = shift;
    my %args = @_;

    if(ref $this) {
      # Cloning!
      my $that = $this;
      $this = fields::new(ref $that);
      foreach my $field (keys %$that) {

	if(ref $that->{$field} eq 'ARRAY') {
	  $this->{$field} = [ @{$that->{$field}} ];
	} elsif(ref $that->{$field}) {
	  die "Don't know how to clone non-array ref field $field in ".
	    "DiagList::Diag\n";
	} else {
	  $this->{$field} = $that->{$field};
	}

      }

    } else {
      $this = fields::new($this);

      foreach my $arg (keys %args) {
	$this->{$arg} = $args{$arg};
      }

    }


    $this->{args}       = [] unless defined $this->{args};
    $this->{files}      = [] unless defined $this->{files};

    return $this;
  }

  ############################################################################

  sub new_from_line {
    my $class   = shift;
    my $line    = shift;
    my $nametag = shift;

    $nametag = '' unless defined $nametag;
    my @fields = split ' ', $line;
    my $alias  = shift @fields;

    my @args;
    my @files;
    my $debugowner;

    my $suffix_re = join '|', @FILE_SUFFIXES;
    $suffix_re = qr/($suffix_re)/;

    foreach my $field (@fields) {
      if($field !~ /^[-+]/ and $field =~ /\.$suffix_re$/o) {
	push @files, $field;
      } else {

	if($field =~ /^debugowner=(\S+)$/) {
	  $debugowner = $1;
	} else {
	  push @args, $field;
	}
      }
    }
	
    my $diag = $class->new(
			   alias => $alias,
			   nametag => $nametag,
			   name => "$alias:$nametag",
			   files => \@files,
			   args  => \@args,
			  );

    $diag->{debugowner} = $debugowner if defined $debugowner;
    return $diag;
  }

  ############################################################################

  sub get_file {
    my $this = shift;
    return $this->{files}[0];
  }

  ############################################################################

  sub prepend_args {
    my $this = shift;
    my $args = shift;

    unshift @{$this->{args}}, @$args;
  }

  ############################################################################

  sub add_owner {
    my $this = shift;
    my $owner = shift;

    $this->{debugowner} = $owner;
  }

  ############################################################################

  sub get_owner {
    my $this = shift;
    return $this->{debugowner} if defined $this->{debugowner};
    return;
  }

  ############################################################################

  sub get_cmdline {
    my $this = shift;

    my @args = grep { $_ =~ /\S/ } @{$this->{args}};
    my $args  = (scalar @args) ? join ' ', @args : '';
    my $files = join ' ', @{$this->{files}};
    my $sep = (length $args) ? ' ' : '';
    my $cmdline = "$args$sep$files";
    $cmdline =~ s/^\s+//;
    $cmdline =~ s/\s+$//;
    return $cmdline;
  }

  ############################################################################

  sub get_cmd_argv {
    my $this = shift;
    my $line = $this->get_cmdline;

    my $keep = 0;
    my @words = `showargv $line`;

    my @argv;
    my $i = 0;
    while($i <= $#words) {
      my $word = $words[$i];

      # Strip off ARGV stuff at beginning of line
      # If next line doesn't start with /^ARGV/, then there must be an
      # embedded newline
      $word =~ s/^ARGV\[\d+\]\://;
      chomp $word;
      $i++;

      if($i > $#words) {
	push @argv, $word;
	last;
      }

      while($words[$i] !~ /^ARGV/) {
	my $new_word = $words[$i];
	$word .= "\n" . $new_word;
	chomp $new_word;
	$i++;
	if($i > $#words) {
	  push @argv, $word;
	  last;
	}
      }

      push @argv, $word;
    }

    # get rid of argv[0] (showargv executable)
    shift @argv;

    return @argv;
  }

  ############################################################################

  sub get_name {
    my $this = shift;
    return $this->{name};
  }

  ############################################################################

  sub get_alias {
    my $this = shift;
    return $this->{alias};
  }

  ############################################################################

  sub get_nametag {
    my $this = shift;
    return $this->{nametag};
  }

  ############################################################################

  sub set_group {
    my $this = shift;
    my $group = shift;
    $this->{group} = $group if defined $group;
    return $this->{group};
  }

  ############################################################################

  sub get_group {
    my $this = shift;
    return $this->{group};
  }

  ############################################################################

  sub get_full_name {
    my $this = shift;
    my $fullname = $this->{alias} . ':' . $this->{nametag} . ':' .
      $this->{group};
    return $fullname;
  }

  ############################################################################


  ############################################################################
}

##############################################################################

1;
Commit	Line	Data
86530b38 AT	1	# ========== Copyright Header Begin ==========================================
	2	#
	3	# OpenSPARC T2 Processor File: Objects.pm
	4	# Copyright (C) 1995-2007 Sun Microsystems, Inc. All Rights Reserved
	5	# 4150 Network Circle, Santa Clara, California 95054, U.S.A.
	6	#
	7	# * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
	8	#
	9	# This program is free software; you can redistribute it and/or modify
	10	# it under the terms of the GNU General Public License as published by
	11	# the Free Software Foundation; version 2 of the License.
	12	#
	13	# This program is distributed in the hope that it will be useful,
	14	# but WITHOUT ANY WARRANTY; without even the implied warranty of
	15	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	16	# GNU General Public License for more details.
	17	#
	18	# You should have received a copy of the GNU General Public License
	19	# along with this program; if not, write to the Free Software
	20	# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
	21	#
	22	# For the avoidance of doubt, and except that if any non-GPL license
	23	# choice is available it will apply instead, Sun elects to use only
	24	# the General Public License version 2 (GPLv2) at this time for any
	25	# software where a choice of GPL license versions is made
	26	# available with the language indicating that GPLv2 or any later version
	27	# may be used, or where a choice of which version of the GPL is applied is
	28	# otherwise unspecified.
	29	#
	30	# Please contact Sun Microsystems, Inc., 4150 Network Circle, Santa Clara,
	31	# CA 95054 USA or visit www.sun.com if you need additional information or
	32	# have any questions.
	33	#
	34	# ========== Copyright Header End ============================================
	35	package DiagList::Objects;
	36
	37	use strict;
	38	use DiagList::Output;
	39	use DiagList::Settings;
	40
	41	###############################################################################
	42
	43	{
	44	package DiagList;
	45
	46	use DiagList::Output;
	47	use DiagList::Settings;
	48
	49	use fields qw(
	50	file
	51	buildtags
	52	groups
	53	);
	54
	55	our $COMMENT_RE = qr\|\/\/\|;
	56	our $TAG_RE =
	57	qr\|^
	58	\s*
	59	\<
	60	\s*
	61	(\S+)
	62	\s*
	63	(.*)
	64	\>
65	\|x;
66
67	#############################################################################
68
69	sub new {
70	my $class = shift;
71	my $file = shift;
72	my $fh = shift;
73
74	my $this = {};
75	bless $this, $class;
76
77	tie my %buildtags, 'Tie::IxHash';
78	$this->{buildtags} = \%buildtags;
79	tie my %groups, 'Tie::IxHash';
80	$this->{groups} = \%groups;
81	$this->parse($file, $fh) if defined $file;
82	return $this;
83	}
84
85	#############################################################################
86
87	sub parse {
88	my $this = shift;
89	my $file = shift;
90	my $fh = shift;
91
92	chat "Reading $file";
93	$this->{file} = $file;
94
95	if(defined $fh and not (ref $fh and $fh->isa('IO::File'))) {
96	my $handle = $fh;
97	$fh = IO::File->new();
98	$fh->fdopen(fileno($handle), "r") or
99	fatal "Cannot create IO::File object from handle $handle\n";
100	} else {
101	$fh = IO::File->new("<$file") or fatal "Cannot open $file: $!";
102	}
103
104	my $line = 0;
105
106	my $cur_build_tag;
107	my $cur_name_tag;
108
109	my @group_stack;
110	my %group_args;
111	my @runarg_stack;
112	my @owner_stack;
113
114	while(<$fh>) {
115	$line++;
116	chomp;
117	s/$COMMENT_RE.*//;
118	next unless /\S/;
119
120
121	if(/^\#\s(\d+)\s\"(.*)\"/) {
122	$line = $1 - 1;
123	$file = $2;
124	next;
125	}
126
127	if(/$TAG_RE/) {
128	my ($tag, $args) = ($1, $2);
129
130	if($tag =~ s\|^\/\|\|) {
131	# End tag
132
133	if($tag eq 'runargs') {
134	fatal "Nesting error, </runargs> with no matching beginning",
135	$file, $line unless @runarg_stack;
136	pop @runarg_stack;
137	} elsif($tag eq 'debugowner') {
138	fatal "Nesting error, </debugowners> with no matching beginning",
139	$file, $line unless @owner_stack;
140	pop @owner_stack;
141	} else {
142	my $group = pop @group_stack;
143	fatal "Nesting error: /$tag found, /$group->{name} expected",
144	$file, $line unless $tag eq $group->{name};
145
146	undef $cur_build_tag if $group->compile_tag;
147	undef $cur_name_tag if $group->name_tag;
148	delete $group_args{$group->{name}};
149	}
150
151	} else {
152
153	if($tag eq 'runargs') {
154	push @runarg_stack, $args;
155	} elsif($tag eq 'debugowner') {
156	push @owner_stack, $args;
157	} else {
158
159	# Start tag
160	my $buildtag = ($args =~ /\bsys=(\S+)/);
161	$buildtag = $1 if $buildtag;
162
163	my $nametag = ($args =~ s/\bname=(\S+)\s*//);
164	$nametag = $1 if $nametag;
165
166	# Error checking here
167	fatal "Build tag $tag multiply defined." , $file, $line
168	if exists $this->{buildtags}{$tag};
169
170
171	if($buildtag) {
172	chat "Inserting tags: $tag=$buildtag\n";
173
174	(my $buildargs = $args) =~ s/\b(sys=\S+)/-$1/;
175
176	$this->{buildtags}{$tag} = $buildargs;
177
178	# Strip sys= argument for use in group args
179	$args =~ s/\bsys=(\S)+\s*//;
180
181	$cur_build_tag = $tag;
182
183	}
184	if($nametag) {
185	fatal "Nametag $nametag defined within nametag $cur_name_tag",
186	$file, $line if defined $cur_name_tag;
187	$cur_name_tag = $nametag;
188	}
189
190
191	my $group;
192	if(exists $this->{groups}{$tag}) {
193	fatal "Group $tag is nested inside itself", $file, $line
194	if exists $group_args{$tag};
195
196	$group = $this->{groups}{$tag};
197	} else {
198
199	$group = DiagList::Group->new(name => $tag);
200	$group->compile_tag($buildtag) if $buildtag;
201	$group->name_tag($nametag) if $nametag;
202
203
204	$this->{groups}{$group->{name}} = $group;
205	}
206	$args =~ s/^\s+//;
207	$args =~ s/\s+$//;
208	$group_args{$group->{name}} = $args;
209	push @group_stack, $group;
210	}
211	}
212	} else {
213	# Diag
214
215	my $diag = DiagList::Diag->new_from_line($_, $cur_name_tag);
216
217	fatal "Diag $diag->{alias} appears outside any group.", $file, $line
218	unless @group_stack;
219	fatal "Diag $diag->{alias} appears outside any name tag.", $file, $line
220	unless defined $cur_name_tag;
221	fatal "Diag $diag->{name} appears outside any build tag.", $file, $line
222	unless defined $cur_build_tag;
223
224	foreach my $group (@group_stack) {
225	my $group_diag = $diag->new(); # Clone diag object
226	$group_diag->prepend_args([@runarg_stack,
227	$group_args{$group->{name}}]);
228	$group_diag->set_group($group->{name});
229	$group->add_diag($group_diag, $cur_build_tag);
230	if(@owner_stack) {
231	my $owner = $owner_stack[$#owner_stack];
232	$group_diag->add_owner($owner) unless
233	defined $group_diag->get_owner(); # diag has owner on cmdline
234	}
235	}
236
237	}
238
239	}
240
241	fatal "End of file with <runargs> still open!" if @runarg_stack;
242
243	undef $fh;
244	}
245
246	#############################################################################
247
248	sub build_hash {
249	my $this = shift;
250	return $this->{buildtags};
251	}
252
253	#############################################################################
254
255	sub build_list {
256	my $this = shift;
257	return keys %{$this->{buildtags}};
258	}
259
260	#############################################################################
261
262	sub build_args {
263	my $this = shift;
264	my $build_tag = shift;
265	return unless exists $this->{buildtags}{$build_tag};
266	return $this->{buildtags}{$build_tag};
267	}
268
269	#############################################################################
270
271	sub group_hash {
272	my $this = shift;
273	return $this->{groups};
274	}
275
276	#############################################################################
277
278	sub group_list {
279	my $this = shift;
280	return keys %{$this->{groups}};
281	}
282
283	#############################################################################
284
285	sub find_group {
286	my $this = shift;
287	my $group = shift;
288
289	return unless exists $this->{groups}{$group};
290	return $this->{groups}{$group};
291	}
292
293	#############################################################################
294
295	}
296
297	###############################################################################
298	##############################################################################
299
300	{
301	package DiagList::Group;
302	use strict;
303
304	use DiagList::Settings;
305
306	use fields qw(
307	name
308	compile_tag
309	name_tag
310
311	tags
312	);
313
314	############################################################################
315
316	sub new {
317	my $this = shift;
318	my %args = @_;
319
320	unless (ref $this) {
321	$this = fields::new($this);
322	}
323
324	foreach my $arg (keys %args) {
325	$this->{$arg} = $args{$arg};
326	}
327	$this->{tags} = {} unless defined $this->{tags};
328
329	return $this;
330	}
331
332	############################################################################
333
334	sub name {
335	my $this = shift;
336	my $name = shift;
337	$this->{name} = $name if defined $name;
338	return $this->{name};
339	}
340
341	############################################################################
342
343	sub compile_tag {
344	my $this = shift;
345	my $tag = shift;
346
347	$this->{compile_tag} = undef unless exists $this->{compile_tag};
348	$this->{compile_tag} = $tag if defined $tag;
349	return $this->{compile_tag};
350	}
351
352	############################################################################
353
354	sub name_tag {
355	my $this = shift;
356	my $tag = shift;
357
358	$this->{name_tag} = undef unless exists $this->{name_tag};
359	$this->{name_tag} = $tag if defined $tag;
360	return $this->{name_tag};
361	}
362
363	############################################################################
364
365	sub build_tags {
366	my $this = shift;
367	my $name = shift;
368	return keys %{$this->{tags}};
369	}
370
371	############################################################################
372
373	sub list_diags {
374	my $this = shift;
375	my $buildtag = shift;
376
377	return unless exists $this->{tags}{$buildtag};
378	return keys %{$this->{tags}{$buildtag}};
379	}
380
381	############################################################################
382
383	sub diag_hash {
384	my $this = shift;
385	my $buildtag = shift;
386	return unless exists $this->{tags}{$buildtag};
387	return $this->{tags}{$buildtag};
388	}
389
390	############################################################################
391
392	sub find_diag {
393	my $this = shift;
394	my $buildtag = shift;
395	my $diagname = shift;
396
397	return unless exists $this->{tags}{$buildtag};
398	return unless exists $this->{tags}{$buildtag}{$diagname};
399	return $this->{tags}{$buildtag}{$diagname};
400	}
401
402	############################################################################
403
404	sub add_diag {
405	my $this = shift;
406	my $diag = shift;
407	my $buildtag = shift;
408
409	if(not defined $this->{tags}{$buildtag}) {
410	tie my %sys, 'Tie::IxHash';
411	$this->{tags}{$buildtag} = \%sys;
412	}
413
414	my $key = $diag->{name};
415	my $gname = $this->{name};
416
417	warn "WARNING: Diag $key multiply defined in group $gname\n"
418	if (exists $this->{tags}{$buildtag}{$key} and display_warnings());
419
420	$this->{tags}{$buildtag}{$key} = $diag;
421
422	}
423
424	############################################################################
425	}
426
427	##############################################################################
428
429	{
430	package DiagList::Diag;
431	use strict;
432
433	use Text::ParseWords;
434
435	use fields qw(
436	name
437	alias
438	files
439	args
440
441	nametag
442	buildtag
443	group
444	debugowner
445	);
446
447	our @FILE_SUFFIXES = qw(s pal vr tpt);
448
449	############################################################################
450
451	sub new {
452	my $this = shift;
453	my %args = @_;
454
455	if(ref $this) {
456	# Cloning!
457	my $that = $this;
458	$this = fields::new(ref $that);
459	foreach my $field (keys %$that) {
460
461	if(ref $that->{$field} eq 'ARRAY') {
462	$this->{$field} = [ @{$that->{$field}} ];
463	} elsif(ref $that->{$field}) {
464	die "Don't know how to clone non-array ref field $field in ".
465	"DiagList::Diag\n";
466	} else {
467	$this->{$field} = $that->{$field};
468	}
469
470	}
471
472	} else {
473	$this = fields::new($this);
474
475	foreach my $arg (keys %args) {
476	$this->{$arg} = $args{$arg};
477	}
478
479	}
480
481
482	$this->{args} = [] unless defined $this->{args};
483	$this->{files} = [] unless defined $this->{files};
484
485	return $this;
486	}
487
488	############################################################################
489
490	sub new_from_line {
491	my $class = shift;
492	my $line = shift;
493	my $nametag = shift;
494
495	$nametag = '' unless defined $nametag;
496	my @fields = split ' ', $line;
497	my $alias = shift @fields;
498
499	my @args;
500	my @files;
501	my $debugowner;
502
503	my $suffix_re = join '\|', @FILE_SUFFIXES;
504	$suffix_re = qr/($suffix_re)/;
505
506	foreach my $field (@fields) {
507	if($field !~ /^[-+]/ and $field =~ /\.$suffix_re$/o) {
508	push @files, $field;
509	} else {
510
511	if($field =~ /^debugowner=(\S+)$/) {
512	$debugowner = $1;
513	} else {
514	push @args, $field;
515	}
516	}
517	}
518
519	my $diag = $class->new(
520	alias => $alias,
521	nametag => $nametag,
522	name => "$alias:$nametag",
523	files => \@files,
524	args => \@args,
525	);
526
527	$diag->{debugowner} = $debugowner if defined $debugowner;
528	return $diag;
529	}
530
531	############################################################################
532
533	sub get_file {
534	my $this = shift;
535	return $this->{files}[0];
536	}
537
538	############################################################################
539
540	sub prepend_args {
541	my $this = shift;
542	my $args = shift;
543
544	unshift @{$this->{args}}, @$args;
545	}
546
547	############################################################################
548
549	sub add_owner {
550	my $this = shift;
551	my $owner = shift;
552
553	$this->{debugowner} = $owner;
554	}
555
556	############################################################################
557
558	sub get_owner {
559	my $this = shift;
560	return $this->{debugowner} if defined $this->{debugowner};
561	return;
562	}
563
564	############################################################################
565
566	sub get_cmdline {
567	my $this = shift;
568
569	my @args = grep { $_ =~ /\S/ } @{$this->{args}};
570	my $args = (scalar @args) ? join ' ', @args : '';
571	my $files = join ' ', @{$this->{files}};
572	my $sep = (length $args) ? ' ' : '';
573	my $cmdline = "$args$sep$files";
574	$cmdline =~ s/^\s+//;
575	$cmdline =~ s/\s+$//;
576	return $cmdline;
577	}
578
579	############################################################################
580
581	sub get_cmd_argv {
582	my $this = shift;
583	my $line = $this->get_cmdline;
584
585	my $keep = 0;
586	my @words = `showargv $line`;
587
588	my @argv;
589	my $i = 0;
590	while($i <= $#words) {
591	my $word = $words[$i];
592
593	# Strip off ARGV stuff at beginning of line
594	# If next line doesn't start with /^ARGV/, then there must be an
595	# embedded newline
596	$word =~ s/^ARGV\[\d+\]\://;
597	chomp $word;
598	$i++;
599
600	if($i > $#words) {
601	push @argv, $word;
602	last;
603	}
604
605	while($words[$i] !~ /^ARGV/) {
606	my $new_word = $words[$i];
607	$word .= "\n" . $new_word;
608	chomp $new_word;
609	$i++;
610	if($i > $#words) {
611	push @argv, $word;
612	last;
613	}
614	}
615
616	push @argv, $word;
617	}
618
619	# get rid of argv[0] (showargv executable)
620	shift @argv;
621
622	return @argv;
623	}
624
625	############################################################################
626
627	sub get_name {
628	my $this = shift;
629	return $this->{name};
630	}
631
632	############################################################################
633
634	sub get_alias {
635	my $this = shift;
636	return $this->{alias};
637	}
638
639	############################################################################
640
641	sub get_nametag {
642	my $this = shift;
643	return $this->{nametag};
644	}
645
646	############################################################################
647
648	sub set_group {
649	my $this = shift;
650	my $group = shift;
651	$this->{group} = $group if defined $group;
652	return $this->{group};
653	}
654
655	############################################################################
656
657	sub get_group {
658	my $this = shift;
659	return $this->{group};
660	}
661
662	############################################################################
663
664	sub get_full_name {
665	my $this = shift;
666	my $fullname = $this->{alias} . ':' . $this->{nametag} . ':' .
667	$this->{group};
668	return $fullname;
669	}
670
671	############################################################################
672
673
674	############################################################################
675	}
676
677	##############################################################################
678
679	1;