src/Utilities/Architecture.pm

#
#____________________________________________________________________ 
# File: Architecture.pm
#____________________________________________________________________ 
#  
# Author: Shaun Ashby <Shaun.Ashby@cern.ch>
# Update: 2003-10-23 17:20:41+0200
# Revision: $Id: Architecture.pm,v 1.3 2004/02/16 13:24:33 sashby Exp $ 
#
# Copyright: 2003 (C) Shaun Ashby
#
#--------------------------------------------------------------------
package Architecture;
require 5.004;

use Exporter;

@ISA=qw(Exporter);
@EXPORT_OK=qw( );


sub new
   {
   ###############################################################
   # new                                                         #
   ###############################################################
   # modified : Thu Oct 23 17:21:05 2003 / SFA                   #
   # params   :                                                  #
   #          :                                                  #
   # function :                                                  #
   #          :                                                  #
   ###############################################################
   my $proto=shift;
   my $class=ref($proto) || $proto;
   my $self={};
   
   bless $self,$class;

   $self->realarch($^O); # Set the real arch as
                         # Perl tells us.
   $self->_initarch();   # Now try to do the right
                         # thing.
   return $self;
   }

sub realarch
   {
   my $self=shift;

   @_ ? $self->{realarch} = shift
      : $self->{realarch};
   }

sub mappedarch
   {
   my $self=shift;

   @_ ? $self->{mappedarch} = shift
      : $self->{mappedarch};
   }

sub arch
   {
   my $self=shift;
   
   @_ ? $self->{arch} = shift
      : $self->{arch};
   }

# A subroutine to determine the architecture. The SCRAM_ARCH
# can be set from this in the main part of SCRAM, or this can
# be mapped to have another architecture name:
sub _initarch
   {
   my $self=shift;
   # For WIN32, just take what Perl gives us:
   if ( $self->realarch() =~ /(MSWin32|cygwin)/ )
      {
      $self->arch($1);
      }
   else
      {
      my $uname=`uname -a`;
      my ($name, $hostname, $version, @rest) = split / /, $uname;
      
      # Retain only the first two version digits
      # of os version from uname:
      if ( $name =~ SunOS )
         {
         $version =~ s/^(.\..)\..*/\1/;
         $self->arch($name."__".$version);
         }
      # Linux:
      elsif ( $name =~ Linux )
         {
         # Firstly we check for the kernel version.
         $version =~ s/^(.\..)\..*/\1/;
         # Now, we also check for the libc version to confirm (or otherwise)
         # the choice determined by the previous step:
         $self->glibccheck($name,$version);
         }
      else
         {
         # At this point it looks like the platform is "other". 
         # Set SCRAM_ARCH anyway to the default:
         $self->arch($name."__".$version);
         }
      }
   
   # Set arch flag to [OS name]__[version] if not set by now:
   if ( ! defined $self->arch() )
      {
      $self->arch($name."__".$version);
      }
   
   # Now translate this arch to something else if defined in arch.map:
   $self->parse_map();

   return $self;
   }

# Sub routine to check the version of glibc if this platform,
# at first guess, is Linux:
sub glibccheck
   {
   my $self=shift;
   my ($name,$version)=@_;
   
   my $lddcmd="ldd /bin/ls";
   
   # Open the ldd command as a pipe:
   my $pid = open(LDD,"$lddcmd 2>&1 |");
   
   # Check that we were able to fork:
   if (defined($pid))
      {
      # Loop over lines of output:
      while (<LDD>)
         {
         chomp $_;
         # Grab something that looks like "libc.*":
         if (my ($libc) = ($_ =~ /\s+libc\.so.*\s.*\s(.*)\s.*/))
            {
            # Check if this libc thing is a soft link (it should be), then
            # find out what the thingy is that the link points to:
            if ( -l $libc && defined($value = readlink $libc))
               {
               # Extract the useful numeric info from this:    
               my ($libcmaj,$libcmin,$libcpatch) = ($value =~ /^libc-([0-9]+)\.([0-9]+)\.([0-9]+)\.so/);
               
               # Set the arch accordingly:
               if ($libcmaj == 2 && $libcmin == 1 && $libcpatch >= 3)
                  {
                  $self->arch("Linux__2.2");
                  }
               
               if ($libcmaj == 2 && $libcmin == 2 && $libcpatch >= 4)
                  {
                  $self->arch("Linux__2.4");
                  }
               
               if ($libcmaj == 2 && $libcmin == 3 && $libcpatch >= 2)
                  {
                  $self->arch("Linux__2.4");
                  }     
               }
            # No need to check other lines:
            last;
            }
         }
      }
   else
      # Fork failed, so we must fall back to
      # the normal mechanism to define the arch:
      {
      $self->arch($name."__".$version);
      }
   return $self;
   }

# This subrtn parses an architecture map file found in config dir.
# The ides is to translate the architecture that scram determines automatically into
# some other string that will then become the recognised SCRAM_ARCH for the project:
# Format of an entry in arch.map is like this
#
#     Linux__2.4->rh73_gcc32
# 
#    (REAL arch)->(MAPPED arch)
#
sub parse_map()
   {
   my $self=shift;

   # Only swap archs in project areas:
   if ( defined $ENV{LOCALTOP} )
      {
      my $configdir=$ENV{LOCALTOP}."/".$ENV{SCRAM_CONFIGDIR};
      my $mapfile=$configdir."/arch.map";
      # Check for a map file:
      if ( -f $mapfile )
         {
         open(ARCHMAP,"< $mapfile") || die "Unable to open architecture map file: $!","\n";
         while (<ARCHMAP>)
            {
            my ($scram_arch,$req_arch) = ($_ =~ /^(.*)?->(.*)?/);
            if ($self->arch() eq $scram_arch)
               {
               $self->mappedarch($req_arch);
               $self->realarch($scram_arch);
               $self->arch($req_arch);
               }
            }
         }
      }
   return $self;
   }


1;
Revision:	1.1.4.1
Committed:	Fri Feb 27 15:34:56 2004 UTC (21 years, 2 months ago) by sashby
Content type:	text/plain
Branch:	SCRAM_V1_BRANCH
CVS Tags:	V1_pre0, SCRAM_V1, SCRAMV1_IMPORT
Branch point for:	V1_pre1
Changes since 1.1:	+216 -56 lines
Log Message:	First import of new SCRAM packages into CMS cvs repos.
#	Content
1	#
2	#____________________________________________________________________
3	# File: Architecture.pm
4	#____________________________________________________________________
5	#
6	# Author: Shaun Ashby <Shaun.Ashby@cern.ch>
7	# Update: 2003-10-23 17:20:41+0200
8	# Revision: $Id: Architecture.pm,v 1.3 2004/02/16 13:24:33 sashby Exp $
9	#
10	# Copyright: 2003 (C) Shaun Ashby
11	#
12	#--------------------------------------------------------------------
13	package Architecture;
14	require 5.004;
15
16	use Exporter;
17
18	@ISA=qw(Exporter);
19	@EXPORT_OK=qw( );
20
21
22
23	sub new
24	{
25	###############################################################
26	# new #
27	###############################################################
28	# modified : Thu Oct 23 17:21:05 2003 / SFA #
29	# params : #
30	# : #
31	# function : #
32	# : #
33	###############################################################
34	my $proto=shift;
35	my $class=ref($proto) \|\| $proto;
36	my $self={};
37
38	bless $self,$class;
39
40	$self->realarch($^O); # Set the real arch as
41	# Perl tells us.
42	$self->_initarch(); # Now try to do the right
43	# thing.
44	return $self;
45	}
46
47	sub realarch
48	{
49	my $self=shift;
50
51	@_ ? $self->{realarch} = shift
52	: $self->{realarch};
53	}
54
55	sub mappedarch
56	{
57	my $self=shift;
58
59	@_ ? $self->{mappedarch} = shift
60	: $self->{mappedarch};
61	}
62
63	sub arch
64	{
65	my $self=shift;
66
67	@_ ? $self->{arch} = shift
68	: $self->{arch};
69	}
70
71	# A subroutine to determine the architecture. The SCRAM_ARCH
72	# can be set from this in the main part of SCRAM, or this can
73	# be mapped to have another architecture name:
74	sub _initarch
75	{
76	my $self=shift;
77	# For WIN32, just take what Perl gives us:
78	if ( $self->realarch() =~ /(MSWin32\|cygwin)/ )
79	{
80	$self->arch($1);
81	}
82	else
83	{
84	my $uname=`uname -a`;
85	my ($name, $hostname, $version, @rest) = split / /, $uname;
86
87	# Retain only the first two version digits
88	# of os version from uname:
89	if ( $name =~ SunOS )
90	{
91	$version =~ s/^(.\..)\..*/\1/;
92	$self->arch($name."__".$version);
93	}
94	# Linux:
95	elsif ( $name =~ Linux )
96	{
97	# Firstly we check for the kernel version.
98	$version =~ s/^(.\..)\..*/\1/;
99	# Now, we also check for the libc version to confirm (or otherwise)
100	# the choice determined by the previous step:
101	$self->glibccheck($name,$version);
102	}
103	else
104	{
105	# At this point it looks like the platform is "other".
106	# Set SCRAM_ARCH anyway to the default:
107	$self->arch($name."__".$version);
108	}
109	}
110
111	# Set arch flag to [OS name]__[version] if not set by now:
112	if ( ! defined $self->arch() )
113	{
114	$self->arch($name."__".$version);
115	}
116
117	# Now translate this arch to something else if defined in arch.map:
118	$self->parse_map();
119
120	return $self;
121	}
122
123	# Sub routine to check the version of glibc if this platform,
124	# at first guess, is Linux:
125	sub glibccheck
126	{
127	my $self=shift;
128	my ($name,$version)=@_;
129
130	my $lddcmd="ldd /bin/ls";
131
132	# Open the ldd command as a pipe:
133	my $pid = open(LDD,"$lddcmd 2>&1 \|");
134
135	# Check that we were able to fork:
136	if (defined($pid))
137	{
138	# Loop over lines of output:
139	while (<LDD>)
140	{
141	chomp $_;
142	# Grab something that looks like "libc.*":
143	if (my ($libc) = ($_ =~ /\s+libc\.so.\s.\s(.)\s./))
144	{
145	# Check if this libc thing is a soft link (it should be), then
146	# find out what the thingy is that the link points to:
147	if ( -l $libc && defined($value = readlink $libc))
148	{
149	# Extract the useful numeric info from this:
150	my ($libcmaj,$libcmin,$libcpatch) = ($value =~ /^libc-([0-9]+)\.([0-9]+)\.([0-9]+)\.so/);
151
152	# Set the arch accordingly:
153	if ($libcmaj == 2 && $libcmin == 1 && $libcpatch >= 3)
154	{
155	$self->arch("Linux__2.2");
156	}
157
158	if ($libcmaj == 2 && $libcmin == 2 && $libcpatch >= 4)
159	{
160	$self->arch("Linux__2.4");
161	}
162
163	if ($libcmaj == 2 && $libcmin == 3 && $libcpatch >= 2)
164	{
165	$self->arch("Linux__2.4");
166	}
167	}
168	# No need to check other lines:
169	last;
170	}
171	}
172	}
173	else
174	# Fork failed, so we must fall back to
175	# the normal mechanism to define the arch:
176	{
177	$self->arch($name."__".$version);
178	}
179	return $self;
180	}
181
182	# This subrtn parses an architecture map file found in config dir.
183	# The ides is to translate the architecture that scram determines automatically into
184	# some other string that will then become the recognised SCRAM_ARCH for the project:
185	# Format of an entry in arch.map is like this
186	#
187	# Linux__2.4->rh73_gcc32
188	#
189	# (REAL arch)->(MAPPED arch)
190	#
191	sub parse_map()
192	{
193	my $self=shift;
194
195	# Only swap archs in project areas:
196	if ( defined $ENV{LOCALTOP} )
197	{
198	my $configdir=$ENV{LOCALTOP}."/".$ENV{SCRAM_CONFIGDIR};
199	my $mapfile=$configdir."/arch.map";
200	# Check for a map file:
201	if ( -f $mapfile )
202	{
203	open(ARCHMAP,"< $mapfile") \|\| die "Unable to open architecture map file: $!","\n";
204	while (<ARCHMAP>)
205	{
206	my ($scram_arch,$req_arch) = ($_ =~ /^(.)?->(.)?/);
207	if ($self->arch() eq $scram_arch)
208	{
209	$self->mappedarch($req_arch);
210	$self->realarch($scram_arch);
211	$self->arch($req_arch);
212	}
213	}
214	}
215	}
216	return $self;
217	}
218
219
220	1;