ViewVC Help

View File | Revision Log | Show Annotations | Root Listing

root/cvsroot/COMP/SCRAM/src/Utilities/Architecture.pm

Comparing COMP/SCRAM/src/Utilities/Architecture.pm (file contents):
Revision 1.1 by williamc, Fri Dec 17 10:23:15 1999 UTC vs.
Revision 1.4 by sashby, Fri Aug 5 16:44:26 2005 UTC

#	Line 1 | Line 1
1	+	#____________________________________________________________________
2	+	# File: Architecture.pm
3	+	#____________________________________________________________________
4	+	#
5	+	# Author: Shaun Ashby <Shaun.Ashby@cern.ch>
6	+	# Update: 2003-10-23 17:20:41+0200
7	+	# Revision: $Id$
8		#
9	<	# Provide machine/architecture information services
3	<	# simply set the architecture variable based on uname
9	>	# Copyright: 2003 (C) Shaun Ashby
10		#
11	<	# ---------
6	<	# Interface
7	<	# ---------
8	<	# new() : new object - will autoinitialise to architecture
9	<	# getarch() : return the current (assumed) architecture
10	<	# archfile($filename,$base) : Will check various relevant architecture specific
11	<	#                             dirs in search for an architecture specific $file
12	<	#                             starting from base
13	<
11	>	#--------------------------------------------------------------------
12		package Architecture;
15	–	require 5.001;
13
14	<	sub new {
15	<	my $class=shift;
16	<	$self={};
17	<	bless $self, $class;
18	<	$self->_initarch();
19	<	return $self;
20	<	}
21	<
22	<	sub getarch {
23	<	my $self=shift;
24	<	return $self->{arch};
25	<	}
26	<
27	<	sub archfile {
28	<	my $self=shift;
29	<	my $filename=shift;
30	<	my $base=shift;
31	<
32	<	my $archdir;
33	<
34	<	foreach $dir ( @{$self->{archdirs}} ) {
35	<	$archdir=$base."/".$dir."/".$filename;
36	<	if  ( -f $archdir ) {
37	<	return $self->{archdir};
38	<	}
39	<	}
40	<	}
41	<
42	<	# ------------ Support Routines ---------------------------------
43	<
44	<	sub _initarch {
45	<	my $self=shift;
46	<
47	<	$self->{realarch}=$;
48	<	# Seperate Variables means we can pretend to be other architectures
49	<	$self->{arch}=$self->{realarch};
50	<
51	<	# get the hostname
52	<	use Sys::Hostname;
53	<	$self->{host}=hostname();
54	<
55	<	# Architecture directory search path
56	<	@{$self->{archdirs}}=( $self->{arch}."/".$self->{host}, "$self->{arch}" );
57	<	}
14	>	=head1 NAME
15	>
16	>	Architecture - Utilities to determine the architecture name.
17	>
18	>	=head1 SYNOPSIS
19	>
20	>	if (! defined $self->{SCRAM_ARCH})
21	>	{
22	>	my $arch = Architecture->new();
23	>	$self->architecture($a->arch());
24	>	$self->system_architecture($a->system_arch_stem());
25	>	$ENV{SCRAM_ARCH} = $self->architecture();
26	>	}
27	>
28	>	=head1 DESCRIPTION
29	>
30	>	A mechanism to extract the current system architecture. The full arch
31	>	and system (short) arch strings can be returned in the application using
32	>	the methods in this package.
33	>
34	>	=head1 METHODS
35	>
36	>	=over
37	>
38	>	=cut
39	>
40	>	require 5.004;
41	>	use Exporter;
42	>
43	>	@ISA=qw(Exporter);
44	>	@EXPORT_OK=qw( );
45	>
46	>	=item   C<new()>
47	>
48	>	Constructor for Architecture objects.
49	>
50	>	=cut
51	>
52	>	sub new()
53	>	{
54	>	###############################################################
55	>	# new()                                                       #
56	>	###############################################################
57	>	# modified : Thu Oct 23 17:21:05 2003 / SFA                   #
58	>	# params   :                                                  #
59	>	#          :                                                  #
60	>	# function :                                                  #
61	>	#          :                                                  #
62	>	###############################################################
63	>	my $proto=shift;
64	>	my $class=ref($proto) || $proto;
65	>	my $self={};
66	>
67	>	bless $self,$class;
68	>
69	>	$self->_initarch();
70	>
71	>	return $self;
72	>	}
73	>
74	>	=item   C<arch()>
75	>
76	>	Method to set or return the architecture name.
77	>
78	>	=cut
79	>
80	>	sub arch()
81	>	{
82	>	my $self=shift;
83	>
84	>	@_ ? $self->{arch} = shift
85	>	: $self->{arch};
86	>	}
87	>
88	>	=item   C<system_arch_stem()>
89	>
90	>	Method to set or return the system architecture name stem. The
91	>	architecture stem is the full architecture without any compiler dependence.
92	>	For example, the architecture B<slc3_ia32_gcc323> has a system architecture
93	>	name stem of B<slc3_ia32>.
94	>
95	>	=cut
96	>
97	>	sub system_arch_stem()
98	>	{
99	>	my $self=shift;
100	>
101	>	@_ ? $self->{archstem} = shift
102	>	: $self->{archstem};
103	>	}
104	>
105	>	=item   C<_initarch()>
106	>
107	>	A subroutine to determine the architecture. This
108	>	is done by parsing the architecture map contained as
109	>	data inside B<SCRAM_SITE.pm> and looking for an appropriate
110	>	match for our platform.
111	>
112	>	=cut
113	>
114	>	sub _initarch()
115	>	{
116	>	my $self=shift;
117	>	$self->parse_architecture_map();
118	>	return $self;
119	>	}
120	>
121	>	=item   C<parse_architecture_map()>
122	>
123	>	Read the architecture map file defined in the site package B<SCRAM_SITE.pm>.
124	>
125	>	=cut
126	>
127	>	sub parse_architecture_map()
128	>	{
129	>	my $self=shift;
130	>	my $matches={};
131	>
132	>	require Installation::SCRAM_SITE;
133	>	my $architectures = &Installation::SCRAM_SITE::read_architecture_map();
134	>
135	>	while (my ($archstring,$archtest) = each %{$architectures})
136	>	{
137	>	my $rval = eval join(" ",@$archtest);
138	>
139	>	if ($rval)
140	>	{
141	>	# Store the matched string:
142	>	$matches->{$archstring}=1;
143	>
144	>	if ((my $nkeys = keys %{$matches}) > 1)
145	>	{
146	>	print "\n";
147	>	print "SCRAM: WARNING: more than one architecture definition in ","\n";
148	>	print "       SCRAM_SITE matches current platform!","\n";
149	>	print "Unable to set the architecture correctly!","\n";
150	>	print "\n";
151	>	exit(1);
152	>	}
153	>
154	>	# Store the match (only the *first* match in the case
155	>	# of multiple matches):
156	>	$self->arch($archstring);
157	>
158	>	# Also take the arch stem from the arch string. E.g. for a string
159	>	# "slc3_ia32_xxx", keep the "slc3_ia32" part:
160	>	if (my ($sysname,$cpuarch) = ($archstring =~ /(.*?)\_(.*?)\_.*?$/))
161	>	{
162	>	my $stem = $sysname."_".$cpuarch;
163	>	$self->system_arch_stem($stem);
164	>	}
165	>	else
166	>	{
167	>	# Just set the stem to be the same as the main arch string:
168	>	$self->system_arch_stem($archstring);
169	>	}
170	>	}
171	>	else
172	>	{
173	>	next;
174	>	}
175	>	}
176	>	}
177	>
178	>	1;
179	>
180	>	__END__
181	>
182	>	=back
183	>
184	>	=head1 AUTHOR/MAINTAINER
185	>
186	>	Shaun Ashby L<mailTo:scram-developers@cern.ch>
187	>
188	>	=cut

Diff Legend

–	Removed lines
+	Added lines
<	Changed lines
>	Changed lines