[perl #112374] Failure with ($>, $<) = ($<, $>) on linux.

# New Ticket Created by  david.Ingamells@mapscape.eu 
# Please include the string:  [perl #112374]
# in the subject line of all future correspondence about this issue. 
# <URL: https://rt.perl.org:443/rt3/Ticket/Display.html?id=112374 >



This is a bug report for perl from David.ingamells@mapscape.eu,
generated with the help of perlbug 1.39 running under perl 5.10.1.


-----------------------------------------------------------------
[Please describe your issue here]
This bug was first reported to the Ubuntu team as bug number 576984 a long time ago
and I have been supporting a patched version (as described below) at our site ever since. They clearly didn't care :(
I hope that you do :)


The following perl (from perl-base) script fails in the new LTS Ubuntu 10.04, it works in LTS version 8.04.

It tests the perl statement

    ($>, $<) = ($<, $>)

which is documented in perl's perlvar maunal page, also in version 5.14.1.
I have tested this with perl 5.10.1 and 5.12 but not with 5.14.

The output expected is in the script's header comments.

Under Ubuntu 10.04 (perl 5.10.1) it results in:

Testing perl version 5.010001
Initially UID = 1000, EUID = 1001
After swap UID = 1001, EUID = 1001
EUID (1001) should be 1000 at /tmp/swap_uid.pl line 16.
ERROR: Test failed.

Notice how the 2 uids are the same after the attempt to swap.

<b>Note to demonstrate this bug the script needs to perform sudo commands.</b> Therefore
  1) check the script first for unsafe behaviour
  2) to run it you will be prompted for your sudo password. Don't run it if you don't have sudo rights

Notes:
1) In the early days of Ubuntu 8.04 there was a similar problem that was fixed at some time.
2) I've now also tested Ubuntu 9.10 (with perl 5.10.0) and it has the same bug.
3) There is possibly a security issue here as a script that assumes that it has swapped the 
   UIDs back will actually be running under a different UID than intended. However
   this is too slight to mark it as a security bug. Please feel free to escalate if you feel differently.
4) This script does not use the suid-perl package that is now deprecated - it is a bug in the core perl program.

Kind regards,
David.

<---begin script--->
#!/usr/bin/perl

# this program should give output like:
#
# Testing perl version 5.008008
# Initially UID = 1020, EUID = 1021
# After swap UID = 1021, EUID = 1020
# After double swap UID = 1020, EUID = 1021
#

use warnings;
use strict;

# This program creates a perl_script:

my $perl_script = "/tmp/swap_uid.pl";

# and a C program that runs this perl script:

my $c_source = "/tmp/run_me.c";
my $c_program = "/tmp/run_me";

# This program is given a different owner ID

my $other_uid = $< + 1;

sub my_system($)
{
    my $command = shift;
    my $result = system $command;
    $result /= 256;

    return $result;
}

sub create_perl_script($)
{
    my $file_name = shift;

    my $script = '#!/usr/bin/perl

use warnings;
use strict;

my $real_uid = $<;
my $eff_uid = $>;

die "Effective UID ($eff_uid) is same as own UID" if ($real_uid == $eff_uid);
print "Testing perl version $]\n";
print "Initially UID = $<, EUID = $>\n";
($<, $>) = ($>, $<);
print "After swap UID = $<, EUID = $>\n";
die "Effective UID ($eff_uid) is same as own UID" if ($real_uid == $eff_uid);
die "UID ($<) should be $eff_uid" if ($< != $eff_uid);
die "EUID ($>) should be $real_uid" if ($> != $real_uid);
($<, $>) = ($>, $<);
print "After double swap UID = $<, EUID = $>\n";
die "Effective UID ($eff_uid) is same as own UID" if ($real_uid == $eff_uid);
die "UID ($<) should be $real_uid" if ($< != $real_uid);
die "EUID ($>) should be $eff_uid" if ($> != $eff_uid);
exit 0;
';

    open my $FH, '>', $file_name or die "Could not open script file";
    print $FH $script or die "Could not print script file";
    close $FH or die "Could not close script file";
    my_system "sudo chmod ug+rx $file_name" and die "Could not set suid bit of program";
}

sub create_program($$$$)
{
    my $source_file = shift;
    my $executable = shift;
    my $exec_owner = shift;
    my $script = shift;

    # See perlsec where this code is presented.
    my $source = '#define REAL_PATH "'. $script . '"
                  main(int ac, char **av)
                  {
                      execv(REAL_PATH, av);
                  }
';

    open my $FH, '>', $source_file or die "Could not open source file";
    print $FH $source or die "Could not print source file";
    close $FH or die "Could not close source file";

    my_system "gcc -o $executable $source_file" and die "Could not compile C program";
    my_system "sudo chown $exec_owner $executable" and die "Could not change ownership of program";
    my_system "sudo chmod ug+s $executable" and die "Could not set suid bit of program";
}

sub run_test($)
{
    my $executable = shift;
    my_system("$executable") and print "ERROR: Test failed.\n";
}

sub cleanup
{

    foreach my $f (@_)
    {
        system "sudo chown $< $f";
        unlink $f;
    }
}

create_perl_script($perl_script);
create_program($c_source, $c_program, $other_uid, $perl_script);
run_test($c_program);
cleanup($c_source, $c_program, $perl_script);
<---- end script ---->

The following code change fixes the problem with perl 5.10 .1. The above script now gives this output:

Testing perl version 5.010001
Initially UID = 1020, EUID = 1021

After swap UID = 1021, EUID = 1020

After double swap UID = 1020, EUID = 1021

PLEASE FIX THE DISTRIBUTED VERSION IN UBUNTU 10.4.

In mg.c use setresuid by preference if it is available and set the saved uid (3rd argument) to the other value so that 
both values (real and effective) are always present among the 3 values the system knows (real, effective and saved).

    case '<':
  PL_uid = SvIV(sv);
  if (PL_delaymagic)
  {
   PL_delaymagic |= DM_RUID;
   break; /* don't do magic till later */
  }

#ifdef HAS_SETRESUID
  {
   Uid_t Curr_uid = getuid();
   Uid_t Curr_euid = geteuid();
   Uid_t saved_Uid = (Curr_uid != (Uid_t)PL_uid) ? Curr_uid : Curr_euid;
   (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, saved_Uid);
  }
#else
#ifdef HAS_SETRUID
  (void)setruid((Uid_t)PL_uid);
#else
#ifdef HAS_SETREUID
  (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
#else
  if (PL_uid == PL_euid)
  { /* special case $< = $> */
#ifdef PERL_DARWIN
     /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
   if (PL_uid != 0 && PerlProc_getuid() == 0)
   {
    (void)PerlProc_setuid(0);
   }
#endif
   (void)PerlProc_setuid(PL_uid);
  }
  else
  {
   PL_uid = PerlProc_getuid();
   Perl_croak(aTHX_ "setruid() not implemented");
  }
#endif
#endif
#endif
  PL_uid = PerlProc_getuid();
  PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
  break;
    case '>':
  PL_euid = SvIV(sv);
  if (PL_delaymagic)
  {
   PL_delaymagic |= DM_EUID;
   break; /* don't do magic till later */
  }
#ifdef HAS_SETRESUID
  {
   Uid_t Curr_uid = getuid();
   Uid_t Curr_euid = geteuid();
   Uid_t saved_Uid = (Curr_euid != (Uid_t)PL_euid) ? Curr_euid : Curr_uid;
   (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, saved_Uid);
  }
#else
#ifdef HAS_SETEUID
  (void)seteuid((Uid_t)PL_euid);
#else
#ifdef HAS_SETREUID
  (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
#else
  if (PL_euid == PL_uid) /* special case $> = $< */
  {
   PerlProc_setuid(PL_euid);
  }
  else
  {
   PL_euid = PerlProc_geteuid();
   Perl_croak(aTHX_ "seteuid() not implemented");
  }
#endif
#endif
#endif

[Please do not change anything below this line]
-----------------------------------------------------------------
---
Flags:
    category=core
    severity=high
---
Site configuration information for perl 5.10.1:

Configured by Debian Project at Fri Apr 22 18:53:20 UTC 2011.

Summary of my perl5 (revision 5 version 10 subversion 1) configuration:
   
  Platform:
    osname=linux, osvers=2.6.24-28-server, archname=x86_64-linux-gnu-thread-multi
    uname='linux allspice 2.6.24-28-server #1 smp wed aug 18 21:17:51 utc 2010 x86_64 gnulinux '
    config_args='-Dusethreads -Duselargefiles -Dccflags=-DDEBIAN -Dcccdlflags=-fPIC -Darchname=x86_64-linux-gnu -Dprefix=/usr -Dprivlib=/usr/share/perl/5.10 -Darchlib=/usr/lib/perl/5.10 -Dvendorprefix=/usr -Dvendorlib=/usr/share/perl5 -Dvendorarch=/usr/lib/perl5 -Dsiteprefix=/usr/local -Dsitelib=/usr/local/share/perl/5.10.1 -Dsitearch=/usr/local/lib/perl/5.10.1 -Dman1dir=/usr/share/man/man1 -Dman3dir=/usr/share/man/man3 -Dsiteman1dir=/usr/local/man/man1 -Dsiteman3dir=/usr/local/man/man3 -Dman1ext=1 -Dman3ext=3perl -Dpager=/usr/bin/sensible-pager -Uafs -Ud_csh -Ud_ualarm -Uusesfio -Uusenm -DDEBUGGING=-g -Doptimize=-O2 -Duseshrplib -Dlibperl=libperl.so.5.10.1 -Dd_dosuid -des'
    hint=recommended, useposix=true, d_sigaction=define
    useithreads=define, usemultiplicity=define
    useperlio=define, d_sfio=undef, uselargefiles=define, usesocks=undef
    use64bitint=define, use64bitall=define, uselongdouble=undef
    usemymalloc=n, bincompat5005=undef
  Compiler:
    cc='cc', ccflags ='-D_REENTRANT -D_GNU_SOURCE -DDEBIAN -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64',
    optimize='-O2 -g',
    cppflags='-D_REENTRANT -D_GNU_SOURCE -DDEBIAN -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include'
    ccversion='', gccversion='4.4.3', gccosandvers=''
    intsize=4, longsize=8, ptrsize=8, doublesize=8, byteorder=12345678
    d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=16
    ivtype='long', ivsize=8, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8
    alignbytes=8, prototype=define
  Linker and Libraries:
    ld='cc', ldflags =' -fstack-protector -L/usr/local/lib'
    libpth=/usr/local/lib /lib /usr/lib /lib64 /usr/lib64
    libs=-lgdbm -lgdbm_compat -ldb -ldl -lm -lpthread -lc -lcrypt
    perllibs=-ldl -lm -lpthread -lc -lcrypt
    libc=/lib/libc-2.11.1.so, so=so, useshrplib=true, libperl=libperl.so.5.10.1
    gnulibc_version='2.11.1'
  Dynamic Linking:
    dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E'
    cccdlflags='-fPIC', lddlflags='-shared -O2 -g -L/usr/local/lib -fstack-protector'

Locally applied patches:
    

---
@INC for perl 5.10.1:
    /etc/perl
    /usr/local/lib/perl/5.10.1
    /usr/local/share/perl/5.10.1
    /usr/lib/perl5
    /usr/share/perl5
    /usr/lib/perl/5.10
    /usr/share/perl/5.10
    /usr/local/lib/site_perl
    .

---
Environment for perl 5.10.1:
    HOME=/data/users/david.ingamells
    LANG (unset)
    LANGUAGE=
    LD_LIBRARY_PATH (unset)
    LOGDIR (unset)
    PATH=.:/data/users/david.ingamells/bin:/data/id/release/MScms/Environment_latest:/data/ops/bin:.:~/bin:/data/id/release/MScms/Environment_latest:/data/ops/bin:/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin:/usr/games
    PERL_BADLANG (unset)
    SHELL=/bin/bash

• [perl #112374] Failure with ($>, $<) = ($<, $>) on linux. by david . Ingamells @ mapscape . eu
• Re: [perl #112374] Failure with ($>, $<) = ($<, $>) on linux. by Leon Timmermans
• Re: [perl #112374] Failure with ($>, $<) = ($<, $>) on linux. by David Ingamells
• Re: [perl #112374] Failure with ($>, $<) = ($<, $>) on linux. by Leon Timmermans
• Re: [perl #112374] Failure with ($>, $<) = ($<, $>) on linux. by Leon Timmermans