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.
#	User	Rev	Content
1	williamc	1.1	#
2	sashby	1.1.4.1	#____________________________________________________________________
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	williamc	1.1	#
10	sashby	1.1.4.1	# Copyright: 2003 (C) Shaun Ashby
11			#
12			#--------------------------------------------------------------------
13	williamc	1.1	package Architecture;
14	sashby	1.1.4.1	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	williamc	1.1
220	sashby	1.1.4.1	1;