1N/A * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 1N/A * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others 1N/A * You may distribute under the terms of either the GNU General Public 1N/A * License or the Artistic License, as specified in the README file. 1N/A * "A ship then new they built for him/of mithril and of elven glass" --Bilbo 1N/A * Be proud that perl(1) may proclaim: 1N/A * Setuid Perl scripts are safer than C programs ... 1N/A * Do not abandon (deprecate) suidperl. Do not advocate C wrappers. 1N/A * The flow was: perl starts, notices script is suid, execs suidperl with same 1N/A * arguments; suidperl opens script, checks many things, sets itself with 1N/A * right UID, execs perl with similar arguments but with script pre-opened on 1N/A * /dev/fd/xxx; perl checks script is as should be and does work. This was 1N/A * insecure: see perlsec(1) for many problems with this approach. 1N/A * The "correct" flow should be: perl starts, opens script and notices it is 1N/A * suid, checks many things, execs suidperl with similar arguments but with 1N/A * same, checks arguments match #! line, sets itself with right UID, execs 1N/A * perl with same arguments; perl checks many things and does work. 1N/A * (Opening the script in perl instead of suidperl, we "lose" scripts that 1N/A * are readable to the target UID but not to the invoker. Where did 1N/A * unreadable scripts work anyway?) 1N/A * For now, suidperl and perl are pretty much the same large and cumbersome 1N/A * program, so suidperl can check its argument list (see comments elsewhere). 1N/A * Original bug report: 1N/A * Comments and discussion with Debian: 1N/A * Debian Security Advisory DSA 431-1 (does not fully fix problem): 1N/A * Previous versions of this patch sent to perl5-porters: 1N/ASchool of Mathematics and Statistics University of Sydney 2006 Australia 1N/A * Use truthful, neat, specific error messages. 1N/A * Cannot always hide the truth; security must not depend on doing so. 1N/A * Use global(?), thread-local fdscript for easier checks. 1N/A * (I do not understand how we could possibly get a thread race: 1N/A * do not all threads go through the same initialization? Or in 1N/A * fact, are not threads started only after we get the script and 1N/A * so know what to do? Oh well, make things super-safe...) 1N/A/* XXX If this causes problems, set i_unistd=undef in the hint file. */ 1N/A /* New() needs interpreter, so call malloc() instead */ 1N/A=head1 Embedding Functions 1N/A=for apidoc perl_alloc 1N/AAllocates a new Perl interpreter. See L<perlembed>. 1N/A /* New() needs interpreter, so call malloc() instead */ 1N/A#
endif /* PERL_IMPLICIT_SYS */ 1N/A=for apidoc perl_construct 1N/AInitializes a new Perl interpreter. See L<perlembed>. 1N/A#
endif /* FAKE_THREADS */ 1N/A#
endif /* USE_5005THREADS */ 1N/A /* Init the real globals (and main thread)? */ 1N/A * Safe to use basic SV functions from now on (though 1N/A * not things like mortals or tainting yet). 1N/A#
endif /* EMULATE_ATOMIC_REFCOUNTS */ 1N/A#
endif /* USE_5005THREADS */ 1N/A /* set read-only and try to insure than we wont see REFCNT==0 1N/A /* Build version strings using "native" characters */ 1N/A /* Note that strtab is a rather special HV. Assumptions are made 1N/A about not iterating on it, and not adding tie magic to it. 1N/A It is properly deallocated in perl_destruct() */ 1N/A /* Use sysconf(_SC_CLK_TCK) if available, if not 1N/A * available or if the sysconf() fails, use the HZ. */ 1N/A=for apidoc nothreadhook 1N/AStub that provides thread hook for perl_destruct when there are 1N/A=for apidoc perl_destruct 1N/AShuts down a Perl interpreter. See L<perlembed>. 1N/A#
endif /* USE_5005THREADS */ 1N/A /* wait for all pseudo-forked children to finish */ 1N/A /* Pass 1 on any remaining threads: detach joinables, join zombies */ 1N/A "perl_destruct: waiting for %d threads...\n",
1N/A "perl_destruct: joining zombie %p\n", t));
1N/A * The SvREFCNT_dec below may take a long time (e.g. av 1N/A * may contain an object scalar whose destructor gets 1N/A * called) so we have to unlock threads_mutex and start 1N/A "perl_destruct: joined zombie %p OK\n", t));
1N/A "perl_destruct: detaching thread %p\n", t));
1N/A * We unlock threads_mutex and t->mutex in the opposite order 1N/A * from which we locked them just so that DETACH won't 1N/A * deadlock if it panics. It's only a breach of good style 1N/A * not a bug since they are unlocks not locks. 1N/A "perl_destruct: ignoring %p (state %u)\n",
1N/A /* fall through and out */ 1N/A /* We leave the above "Pass 1" loop with threads_mutex still locked */ 1N/A /* Pass 2 on remaining threads: wait for the thread count to drop to one */ 1N/A "perl_destruct: final wait for %d threads\n",
1N/A /* At this point, we're the last thread */ 1N/A#
endif /* !defined(FAKE_THREADS) */ 1N/A#
endif /* USE_5005THREADS */ 1N/A /* Need to flush since END blocks can produce output */ 1N/A /* Threads hook has vetoed further cleanup */ 1N/A /* We must account for everything. */ 1N/A /* Destroy the main CV and syntax tree */ 1N/A /* Tell PerlIO we are about to tear things apart in case 1N/A we have layers which are using resources that should 1N/A * Try to destruct global references. We do this first so that the 1N/A * destructors and destructees still exist. Some sv's might remain. 1N/A * Non-referenced objects are on their own. 1N/A /* unhook hooks which will soon be, or use, destroyed data */ 1N/A /* call exit list functions */ 1N/A /* No more IO - including error messages ! */ 1N/A /* The exit() function will do everything that needs doing. */ 1N/A /* jettison our possibly duplicated environment */ 1N/A /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied 1N/A * so we certainly shouldn't free it here 1N/A /* only main thread can free environ[0] contents */ 1N/A /* Must use safesysfree() when working with environ. */ 1N/A#
endif /* !PERL_MICRO */ 1N/A /* the syntax tree is shared between clones 1N/A * so op_free(PL_main_root) only ReREFCNT_dec's 1N/A * REGEXPs in the parent interpreter 1N/A * we need to manually ReREFCNT_dec for the clones 1N/A /* this is PL_reg_curpm, already freed 1N/A /* loosen bonds of global variables */ 1N/A /* Filters for program text */ 1N/A /* magical thingies */ 1N/A /* defgv, aka *_ should be taken care of elsewhere */ 1N/A /* clean up after study() */ 1N/A /* startup and shutdown function lists */ 1N/A /* shortcuts just get cleared */ 1N/A /* reset so print() ends up where we expect */ 1N/A /* free locale stuff */ 1N/A /* clear utf8 character classes */ 1N/A /* Prepare to destruct main symbol table. */ 1N/A /* clear queued errors */ 1N/A "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
1N/A "Unbalanced saves: %ld more saves than restores\n",
1N/A /* Now absolutely destruct everything, somehow or other, loops or no. */ 1N/A /* the 2 is for PL_fdpid and PL_strtab */ 1N/A /* Destruct the global string table. */ 1N/A /* Yell and reset the HeVAL() slots that are still holding refcounts, 1N/A * so that sv_free() won't fail on them. 1N/A "Unbalanced string table refcount: (%d) for \"%s\"",
1N/A /* free the pointer table used for cloning */ 1N/A /* free special SVs */ 1N/A for (i=0; i<=
2; i++) {
1N/A /* No more IO - including error messages ! */ 1N/A /* sv_undef needs to stay immortal until after PerlIO_cleanup 1N/A as currently layers use it rather than Nullsv as a marker 1N/A for no arg - and will try and SvREFCNT_dec it. 1N/A PL_hints = 0;
/* Reset hints. Should hints be per-interpreter ? */ 1N/A#
endif /* EMULATE_ATOMIC_REFCOUNTS */ 1N/A /* As the penultimate thing, free the non-arena SV for thrsv */ 1N/A#
endif /* USE_5005THREADS */ 1N/A /* As the absolutely last thing, free the non-arena SV for mess() */ 1N/A /* it could have accumulated taint magic */ 1N/A /* we know that type >= SVt_PV */ 1N/A=for apidoc perl_free 1N/AReleases a Perl interpreter. See L<perlembed>. 1N/A=for apidoc perl_parse 1N/ATells a Perl interpreter to parse a Perl script. See L<perlembed>. 1N/Asetuid perl scripts securely.\n");
1N/A /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0 1N/A * This MUST be done before any hash stores or fetches take place. 1N/A * If you set PL_rehash_seed (and assumedly also PL_rehash_seed_set) 1N/A * yourself, it is your responsibility to provide a good random seed! 1N/A * You can also define PERL_HASH_SEED in compile time, see hv.h. */ 1N/A#
endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */ 1N/A /* Set PL_origalen be the sum of the contiguous argv[] 1N/A * elements plus the size of the env in case that it is 1N/A * contiguous with the argv[]. This is used in mg.c:Perl_magic_set() 1N/A * as the maximum modifiable length of $0. In the worst case 1N/A * the area we are able to modify is limited to the size of 1N/A * the original argv[0]. (See below for 'contiguous', though.) 1N/A /* Do the mask check only if the args seem like aligned. */ 1N/A /* See if all the arguments are contiguous in memory. Note 1N/A * that 'contiguous' is a loose term because some platforms 1N/A * align the argv[] and the envp[]. If the arguments look 1N/A * like non-aligned, assume that they are 'strictly' or 1N/A * 'traditionally' contiguous. If the arguments look like 1N/A * aligned, we just check that they are within aligned 1N/A * PTRSIZE bytes. As long as no system has something bizarre 1N/A * like the argv[] interleaved with some other data, we are 1N/A * fine. (Did I just evoke Murphy's Law?) --jhi */ 1N/A /* Can we grab env area too to be used as the area for $0? */ 1N/A /* Force copy of environment. */ 1N/A /* Come here if running an undumped a.out. */ 1N/A /* my_exit() was called */ 1N/A * Can we rely on the kernel to start scripts with argv[1] set to 1N/A * contain all #! line switches (the whole line)? (argv[0] is set to 1N/A * the interpreter name, argv[2] to the script name; argv[3] and 1N/A * above may contain other arguments.) 1N/A /* ignore -e for Dev:Pseudo argument */ 1N/A case 'I':
/* -I handled both here and in moreswitches() */ 1N/A sv_catpv(
PL_Sv,
"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
1N/A@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1N/Apush @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1N/Aprint \" \\%ENV:\\n @env\\n\" if @env; \ 1N/Aprint \" \\@INC:\\n @INC\\n\";");
1N/A /* catch use of gnu style long options */ 1N/A if (*s ==
'-' && *(s+
1) ==
'T') {
1N/A "Can't ignore signal CHLD, forcing to default");
1N/A#
endif /* USE_5005THREADS */ 1N/A (*
xsinit)(
aTHX);
/* in case linked C routines want magical variables */ 1N/A /* init_postdump_symbols not currently designed to be called */ 1N/A /* more than once (ENV isn't cleared first, for example) */ 1N/A /* But running with -u leaves %ENV & @ARGV undefined! XXX */ 1N/A /* PL_unicode is turned on by -C or by $ENV{PERL_UNICODE}. 1N/A * PL_utf8locale is conditionally turned on by 1N/A * look like the user wants to use UTF-8. */ 1N/A /* Requires init_predump_symbols(). */ 1N/A /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR 1N/A * and the default open disciplines. */ 1N/A /* now parse the script */ 1N/ATells a Perl interpreter to run. See L<perlembed>. 1N/A case 0:
/* normal completion */ 1N/A case 2:
/* my_exit() */ 1N/A=head1 SV Manipulation Functions 1N/A=for apidoc p||get_sv 1N/AReturns the SV of the specified Perl scalar. If C<create> is set and the 1N/APerl variable does not exist then it will be created. If C<create> is not 1N/Aset and the variable does not exist then NULL is returned. 1N/A#
endif /* USE_5005THREADS */ 1N/A=head1 Array Manipulation Functions 1N/A=for apidoc p||get_av 1N/AReturns the AV of the specified Perl array. If C<create> is set and the 1N/APerl variable does not exist then it will be created. If C<create> is not 1N/Aset and the variable does not exist then NULL is returned. 1N/A=head1 Hash Manipulation Functions 1N/A=for apidoc p||get_hv 1N/AReturns the HV of the specified Perl hash. If C<create> is set and the 1N/APerl variable does not exist then it will be created. If C<create> is not 1N/Aset and the variable does not exist then NULL is returned. 1N/A=head1 CV Manipulation Functions 1N/A=for apidoc p||get_cv 1N/AReturns the CV of the specified Perl subroutine. If C<create> is set and 1N/Athe Perl subroutine does not exist then it will be declared (which has the 1N/Asame effect as saying C<sub name;>). If C<create> is not set and the 1N/Asubroutine does not exist then NULL is returned. 1N/A /* XXX unsafe for threads if eval_owner isn't held */ 1N/A /* XXX this is probably not what they think they're getting. 1N/A * It has the same effect as "sub name;", i.e. just a forward 1N/A/* Be sure to refetch the stack pointer after calling these routines. */ 1N/A=head1 Callback Functions 1N/A=for apidoc p||call_argv 1N/APerforms a callback to the specified Perl sub. See L<perlcall>. 1N/A /* null terminated arg list */ 1N/A=for apidoc p||call_pv 1N/APerforms a callback to the specified Perl sub. See L<perlcall>. 1N/A /* name of the subroutine */ 1N/A=for apidoc p||call_method 1N/APerforms a callback to the specified Perl method. The blessed object must 1N/Abe on the stack. See L<perlcall>. 1N/A /* name of the subroutine */ 1N/A/* May be called with any of a CV, a GV, or an SV containing the name. */ 1N/A=for apidoc p||call_sv 1N/APerforms a callback to the Perl sub whose name is in the SV. See 1N/A /* Handle first BEGIN of -d. */ 1N/A /* Try harder, since this may have been a sighandler, thus 1N/A * curstash may be meaningless. */ 1N/A /* we're trying to emulate pp_entertry() here */ 1N/A /* my_exit() was called */ 1N/A/* Eval a string. The G_EVAL flag is always assumed. */ 1N/A=for apidoc p||eval_sv 1N/ATells Perl to C<eval> the string in the SV. 1N/A /* my_exit() was called */ 1N/A=for apidoc p||eval_pv 1N/ATells Perl to C<eval> the given string and return an SV* result. 1N/A/* Require a module. */ 1N/A=head1 Embedding Functions 1N/A=for apidoc p||require_pv 1N/ATells Perl to C<require> the file named by the string argument. It is 1N/Aanalogous to the Perl code C<eval "require '$file'">. It's even 1N/Aimplemented that way; consider using load_module instead. 1N/A /* This message really ought to be max 23 lines. 1N/A * Removed -h because the user already knows that option. Others? */ 1N/A"-0[octal] specify record separator (\\0, if no argument)",
1N/A"-a autosplit mode with -n or -p (splits $_ into @F)",
1N/A"-c check syntax only (runs BEGIN and CHECK blocks)",
1N/A"-d[:debugger] run program under debugger",
1N/A"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1N/A"-e program one line of program (several -e's allowed, omit programfile)",
1N/A"-F/pattern/ split() pattern for -a switch (//'s are optional)",
1N/A"-i[extension] edit <> files in place (makes backup if extension supplied)",
1N/A"-Idirectory specify @INC/#include directory (several -I's allowed)",
1N/A"-l[octal] enable line ending processing, specifies line terminator",
1N/A"-[mM][-]module execute `use/no module...' before executing program",
1N/A"-n assume 'while (<>) { ... }' loop around program",
1N/A"-p assume loop like -n but print line also, like sed",
1N/A"-P run program through C preprocessor before compilation",
1N/A"-s enable rudimentary parsing for switches after programfile",
1N/A"-S look for programfile using PATH environment variable",
1N/A"-t enable tainting warnings",
1N/A"-T enable tainting checks",
1N/A"-u dump core after parsing program",
1N/A"-U allow unsafe operations",
1N/A"-v print version, subversion (includes VERY IMPORTANT perl info)",
1N/A"-V[:variable] print configuration summary (or a single Config.pm variable)",
1N/A"-w enable many useful warnings (RECOMMENDED)",
1N/A"-W enable all warnings",
1N/A"-x[directory] strip off text before #!perl line and perhaps cd to directory",
1N/A"-X disable all warnings",
1N/A "\nUsage: %s [switches] [--] [programfile] [arguments]",
1N/A/* convert a string of -D options (or digits) into an int. 1N/A * sets *s to point to the char after the options */ 1N/A /* if adding extra options, remember to update DEBUG_MASK */ 1N/A "invalid option -D%c\n", **s);
1N/A "-Dp not implemented on this platform\n");
1N/A/* This routine handles any switches that can be given during run */ 1N/A if (s[
1] ==
'x' && s[
2]) {
1N/A for (s +=
2, e = s; *e; e++);
1N/A rschar = 0;
/* Grandfather -0xFOO as -0 -xFOO. */ 1N/A /* The following permits -d:Mod to accepts arguments following an = 1N/A in the fashion that -MSome::Mod does. */ 1N/A if (*s ==
':' || *s ==
'=') {
1N/A /* We now allow -d:Module=Foo,Bar */ 1N/A#
else /* !DEBUGGING */ 1N/A "Recompile perl with -DDEBUGGING to use -D switch\n");
1N/A if (*(s+
1) ==
'\0') {
1N/A#
endif /* __CYGWIN__ */ 1N/A if (*s ==
'-')
/* Additional switches on #! line. */ 1N/A case 'I':
/* -I handled both here and in parse_body() */ 1N/A /* ignore trailing spaces (possibly followed by other switches) */ 1N/A }
while (*p && *p !=
'-');
1N/A /* -M-foo == 'no foo' */ 1N/A if (*s ==
'-') {
use =
"no "; ++s; }
1N/A /* We allow -M'Module qw(Foo Bar)' */ 1N/A/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */ 1N/A "\n(with %d registered patch%s, " 1N/A "see perl -V for more detail)",
1N/A "\n\nCopyright 1987-2004, Larry Wall\n");
1N/A "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n" 1N/A "maintained by Chris Nandor\n");
1N/A "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1N/A "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n" 1N/A "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1N/A "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" 1N/A "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
1N/A "atariST series port, ++jrb bammi@cadence.com\n");
1N/A "BeOS port Copyright Tom Spindler, 1997-1999\n");
1N/A "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
1N/A "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1N/A "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
1N/A "VM/ESA port by Neale Ferguson, 1998-1999\n");
1N/A "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1N/A "MiNT port by Guido Flohr, 1997-1999\n");
1N/A "EPOC port by Olaf Flebbe, 1999-2002\n");
1N/APerl may be copied only under the terms of either the Artistic License or the\n\ 1N/AGNU General Public License, which may be found in the Perl 5 source kit.\n\n\ 1N/AComplete documentation for Perl, including FAQ lists, should be found on\n\ 1N/Athis system using `man perl' or `perldoc perl'. If you have access to the\n\ 1N/A if (s[
1] ==
'-')
/* Additional switches on #! line. */ 1N/A case 'S':
/* OS/2 needs -S on "extproc" line. */ 1N/A/* compliments of Tom Christiansen */ 1N/A/* unexec() can be found in the Gnu emacs distribution */ 1N/A/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */ 1N/A /* unexec prints msg to stderr in case of failure */ 1N/A/* initialize curinterp */ 1N/A#
else /* !USE_5005THREADS */ 1N/A#
endif /* USE_5005THREADS */ 1N/A /* We must init $/ before switches are processed. */ 1N/A/* PSz 18 Nov 03 fdscript now global but do not change prototype */ 1N/A /* if find_script() returns, it returns a malloc()-ed value */ 1N/A * Tell apart "normal" usage of fdscript, e.g. 1N/A * with bash on FreeBSD: 1N/A * perl <( echo '#!perl -DA'; echo 'print "$0\n"') 1N/A * from usage in suidperl. 1N/A * Does any "normal" usage leave garbage after the number??? 1N/A * Is it a mistake to use a similar /dev/fd/ construct for 1N/A * Be supersafe and do some sanity-checks. 1N/A * Still, can we be sure we got the right thing? 1N/A /* ensure close-on-exec */ 1N/A "You should not call sperl directly; do you need to " 1N/A "change a #! line\nfrom sperl to perl?\n");
1N/A * Do not open (or do other fancy stuff) while setuid. 1N/A * Perl does the open, and hands script to suidperl on a fd; 1N/A * suidperl only does some checks, sets up UIDs and re-execs 1N/A * perl with that fd as it has always done. 1N/A "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
1N/A /* This strips off Perl comments which might interfere with 1N/A the C pre-processor, including #!. #line directives are 1N/A deliberately stripped to avoid confusion with Perl's version 1N/A of #line. FWP played some golf with it so it will fit 1N/A into VMS's 255 character buffer. 1N/A code =
"(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
1N/A code =
"/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
1N/A "PL_preprocess: cmd=\"%s\"\n",
1N/A /* ensure close-on-exec */ 1N/A/* PSz 16 Sep 03 Keep neat error message */ 1N/A * I_SYSSTATVFS HAS_FSTATVFS 1N/A * I_STATFS HAS_FSTATFS HAS_GETFSSTAT 1N/A * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT 1N/A * here so that metaconfig picks them up. */ 1N/A * We used to do this as "plain" user (after swapping UIDs with setreuid); 1N/A * but is needed also on machines without setreuid. 1N/A * Seems safe enough to run as root. 1N/A * Need to check noexec also: nosuid might not be set, the average 1N/A * sysadmin would say that nosuid is irrelevant once he sets noexec. 1N/A * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent(). 1N/A * fstatvfs() is UNIX98. 1N/A * fstatfs() is 4.3 BSD. 1N/A * ustat()+getmnt() is pre-4.3 BSD. 1N/A * getmntent() is O(number-of-mounted-filesystems) and can hang on 1N/A * an irrelevant filesystem while trying to reach the right one. 1N/A /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented 1N/A on platforms where it is present. */ 1N/A#
endif /* fstatvfs */ 1N/A#
endif /* fstatfs */ 1N/A /* NOSTAT_ONE here because we're not examining fields which 1N/A * vary between that case and STAT_ONE. */ 1N/A#
endif /* fstat+ustat+getmnt */ 1N/A /* found the filesystem */ 1N/A }
/* A single fs may well fail its stat(). */ 1N/A#
endif /* getmntent+hasmntopt */ 1N/A /* do we need to emulate setuid on scripts? */ 1N/A /* This code is for those BSD systems that have setuid #! scripts disabled 1N/A * in the kernel because of a security problem. Merely defining DOSUID 1N/A * in perl will not fix that problem, but if you have disabled setuid 1N/A * scripts in the kernel, this will attempt to emulate setuid and setgid 1N/A * on scripts that have those now-otherwise-useless bits set. The setuid 1N/A * root version must be called suidperl or sperlN.NNN. If regular perl 1N/A * discovers that it has opened a setuid script, it calls suidperl with 1N/A * the same argv that it had. If suidperl finds that the script it has 1N/A * just opened is NOT setuid root, it sets the effective uid back to the 1N/A * uid. We don't just make perl setuid root because that loses the 1N/A * effective uid we had before invoking perl, if it was different from the 1N/A * suidperl must be hardlinked to sperlN.NNN (that is what we exec); 1N/A * suidperl called with script open and name changed to /dev/fd/N/X; 1N/A * suidperl croaks if script is not setuid; 1N/A * making perl setuid would be a huge security risk (and yes, that 1N/A * would lose any euid we might have had). 1N/A * DOSUID must be defined in both perl and suidperl, and IAMSUID must 1N/A * be defined in suidperl only. suidperl must be setuid root. The 1N/A * Configure script will set this up for you if you want it. 1N/A * Since the script is opened by perl, not suidperl, some of these 1N/A * checks are superfluous. Leaving them in probably does not lower 1N/A * Do checks even for systems with no HAS_SETREUID. 1N/A * We used to swap, then re-swap UIDs with 1N/A if (setreuid(PL_euid,PL_uid) < 0 1N/A || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid) 1N/A Perl_croak(aTHX_ "Can't swap uid and euid"); 1N/A if (setreuid(PL_uid,PL_euid) < 0 1N/A || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid) 1N/A Perl_croak(aTHX_ "Can't reswap uid and euid"); 1N/A /* On this access check to make sure the directories are readable, 1N/A * there is actually a small window that the user could use to make 1N/A * filename point to an accessible directory. So there is a faint 1N/A * chance that someone could execute a setuid script down in a 1N/A * non-accessible directory. I don't know what to do about that. 1N/A * But I don't think it's too important. The manual lies when 1N/A * it says access() is useful in setuid programs. 1N/A * So, access() is pretty useless... but not harmful... do anyway. 1N/A /* If we can swap euid and uid, then we can determine access rights 1N/A * with a simple stat of the file, and then compare device and 1N/A * inode to make sure we did stat() on the same file we opened. 1N/A * Then we just have to make sure he or she can execute it. 1N/A * As the script is opened by perl, not suidperl, we do not need to 1N/A * care much about access rights. 1N/A * The 'script changed' check is needed, or we can get lied to 1N/A * about $0 with e.g. 1N/A * suidperl /dev/fd/4//bin/x 4<setuidscript 1N/A * Without HAS_SETREUID, is it safe to stat() as root? 1N/A * Are there any operating systems that pass /dev/fd/xxx for setuid 1N/A * pass the script name as we do, so the "script changed" test would 1N/A * fail for them... but we never get here with 1N/A * SETUID_SCRIPTS_ARE_SECURE_NOW defined. 1N/A * This is one place where we must "lie" about return status: not 1N/A * say if the stat() failed. We are doing this as root, and could 1N/A * be tricked into reporting existence or not of files that the 1N/A * "plain" user cannot even see. 1N/A * We used to do this check as the "plain" user (after swapping 1N/A * UIDs). But the check for nosuid and noexec filesystem is needed, 1N/A * and should be done even without HAS_SETREUID. (Maybe those 1N/A * operating systems do not have such mount options anyway...) 1N/A * Seems safe enough to do as root. 1N/A /* PSz 13 Nov 03 But -s was caught elsewhere ... so unsetting it here is useless(?!) */ 1N/A /* Sanity check on line length */ 1N/A /* Allow more than a single space after #! */ 1N/A /* Sanity check on buffer end */ 1N/A /* Sanity check on buffer start */ 1N/A while (*s ==
' ' || *s ==
'\t') s++;
1N/A * #! arg must be what we saw above. They can invoke it by 1N/A * mentioning suidperl explicitly, but they may not add any strange 1N/A * arguments beyond what #! says if they do invoke suidperl that way. 1N/A * The way validarg was set up, we rely on the kernel to start 1N/A * scripts with argv[1] set to contain all #! line switches (the 1N/A * Check that we got all the arguments listed in the #! line (not 1N/A * just that there are no extraneous arguments). Might not matter 1N/A * much, as switches from #! line seem to be acted upon (also), and 1N/A * so may be checked and trapped in perl. But, security checks must 1N/A * be done in suidperl and not deferred to perl. Note that suidperl 1N/A * does not get around to parsing (and checking) the switches on 1N/A * the #! line (but execs perl sooner). 1N/A * Allow (require) a trailing newline (which may be of two 1N/A * characters on some architectures?) (but no other trailing 1N/AFIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
1N/A PL_euid) {
/* oops, we're not the setuid root perl */ 1N/A * When root runs a setuid script, we do not go through the same 1N/A * steps of execing sperl and then perl with fd scripts, but 1N/A * simply set up UIDs within the same perl invocation; so do 1N/A * not have the same checks (on options, whatever) that we have 1N/A * for plain users. No problem really: would have to be a script 1N/A * that does not actually work for plain users; and if root is 1N/A * foolish and can be persuaded to run such an unsafe script, he 1N/A * might run also non-setuid ones, and deserves what he gets. 1N/A * Or, we might drop the PL_euid check above (and rely just on 1N/A * PL_fdscript to avoid loops), and do the execs 1N/A * Pass fd script to suidperl. 1N/A * Exec suidperl, substituting fd script for scriptname. 1N/A * Pass script name as "subdir" of fd, which perl will grok; 1N/A * in fact will use that to distinguish this from "normal" 1N/A * usage, see comments above. 1N/A /* PSz 27 Feb 04 Sanity checks on scriptname */ 1N/A /* Or we might confuse it with an option when replacing 1N/A * name in argument list, below (though we do pointer, not 1N/A * string, comparisons). 1N/A * This seems back to front: we try HAS_SETEGID first; if not available 1N/A * then try HAS_SETREGID; as a last chance we try HAS_SETRESGID. May be OK 1N/A * in the sense that we only want to set EGID; but are there any machines 1N/A * with either of the latter, but not the former? Same with UID, later. 1N/A else if (
PL_uid) {
/* oops, mustn't run as root */ 1N/A /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */ 1N/A/* PSz 16 Sep 03 Keep neat error message */ 1N/A /* We absolutely must clear out any saved ids here, so we */ 1N/A /* exec the real perl, substituting fd script for scriptname. */ 1N/A /* (We pass script name as "subdir" of fd, which perl will grok.) */ 1N/A * It might be thought that using setresgid and/or setresuid (changed to 1N/A * set the saved IDs) above might obviate the need to exec, and we could 1N/A * go on to "do the perl thing". 1N/A * Is there such a thing as "saved GID", and is that set for setuid (but 1N/A * not setgid) execution like suidperl? Without exec, it would not be 1N/A * cleared for setuid (but not setgid) scripts (or might need a dummy 1N/A * We need suidperl to do the exact same argument checking that perl 1N/A * does. Thus it cannot be very small; while it could be significantly 1N/A * smaller, it is safer (simpler?) to make it essentially the same 1N/A * binary as perl (but they are not identical). - Maybe could defer that 1N/A * check to the invoked perl, and suidperl be a tiny wrapper instead; 1N/A * but prefer to do thorough checks in suidperl itself. Such deferral 1N/A * would make suidperl security rely on perl, a design no-no. 1N/A * Setuid things should be short and simple, thus easy to understand and 1N/A * verify. They should do their "own thing", without influence by 1N/A * attackers. It may help if their internal execution flow is fixed, 1N/A * regardless of platform: it may be best to exec anyway. 1N/A * Suidperl should at least be conceptually simple: a wrapper only, 1N/A * never to do any real perl. Maybe we should put 1N/A * Perl_croak(aTHX_ "Suidperl should never do real perl\n"); 1N/A * into the perly bits. 1N/A * Keep original arguments: suidperl already has fd script. 1N/A/* for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ; */ 1N/A/* if (!PL_origargv[which]) { */ 1N/A/* Perl_croak(aTHX_ "Permission denied\n"); */ 1N/A/* PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s", */ 1N/A/* PerlIO_fileno(PL_rsfp), PL_origargv[which])); */ 1N/AFIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1N/A#
endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ 1N/A /* not set-id, must be wrapped */ 1N/A /* skip forward in input to the real script? */ 1N/A /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */ 1N/A /* Pater peccavi, file does not have #! */ 1N/A if (*s ==
'#' && s[
1] ==
'!' && ((s =
instr(s,
"perl")) || (s =
instr(
s2,
"PERL")))) {
1N/A while (*s ==
' ' || *s ==
'\t') s++;
1N/A /* We are always searching for the #!perl line in MacPerl, 1N/A * so if we find it, still keep the line count correct 1N/A * by counting lines we already skipped over 1N/A /* gMacPerl_AlwaysExtract is false in MPW tool */ 1N/A /* Should not happen: */ 1N/A * Should go by suidscript, not uid!=euid: why disallow 1N/A * system("ls") in scripts run from setuid things? 1N/A * Or, is this run before we check arguments and set suidscript? 1N/A * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then? 1N/A * (We never have suidscript, can we be sure to have fdscript?) 1N/A * Or must then go by UID checks? See comments in forbid_setid also. 1N/A/* This is used very early in the lifetime of the program, 1N/A * before even the options are parsed, so PL_tainting has 1N/A * not been initialized properly. */ 1N/A /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia 1N/A * before we have an interpreter-- and the whole point of this 1N/A * function is to be called at such an early stage. If you are on 1N/A * a system with PERL_IMPLICIT_SYS but you do have a concept of 1N/A * "tainted because running with altered effective ids', you'll 1N/A * have to add your own checks somewhere in here. The two most 1N/A * known samples of 'implicitness' are Win32 and NetWare, neither 1N/A * of which has much of concept of 'uids'. */ 1N/A#
endif /* !PERL_IMPLICIT_SYS */ 1N/A /* This is a really primitive check; environment gets ignored only 1N/A * if -T are the first chars together; otherwise one gets 1N/A * "Too late" message. */ 1N/A#
endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ 1N/A * Checks for UID/GID above "wrong": why disallow 1N/A * perl -e 'print "Hello\n"' 1N/A * from within setuid things?? Simply drop them: replaced by 1N/A * This may be too late for command-line switches. Will catch those on 1N/A * the #! line, after finding the script name and setting up 1N/A * parsing (and checking) the switches on the #! line, but checks that 1N/A * the two sets are identical. 1N/A * With SETUID_SCRIPTS_ARE_SECURE_NOW, could we use fdscript, also or 1N/A * instead, or would that be "too late"? (We never have suidscript, can 1N/A * we be sure to have fdscript?) 1N/A * Catch things with suidscript (in descendant of suidperl), even with 1N/A * right UID/GID. Was already checked in suidperl, with #ifdef IAMSUID, 1N/A * below; but I am paranoid. 1N/A * Also see comments about root running a setuid script, elsewhere. 1N/A /* PSz 11 Nov 03 Catch it in suidperl, always! */ 1N/A /* start with 128-item stack and 8K cxstack */ 1N/A /* curstackinfo->si_stack got nuked by sv_free_arenas() */ 1N/A/* This is a function so that we don't hold on to MAXPATHLEN 1N/A bytes of stack longer than necessary 1N/A includes a spurious NUL which will cause $^X to fail in system 1N/A or backticks (this will prevent extensions from being built and 1N/A many tests from working). readlink is not meant to add a NUL. 1N/A Normal readlink works fine. 1N/A /* FreeBSD's implementation is acknowledged to be imperfect, sometimes 1N/A returning the text "unknown" from the readlink rather than the path 1N/A to the executable (or returning an error from the readlink). Any valid 1N/A path has a '/' in it somewhere, so use that to validate the result. 1N/A#
endif /* HAS_PROCSELFEXE */ 1N/A /* $0 is not majick on a Mac */ 1N/A /* Note that if the supplied env parameter is actually a copy 1N/A of the global environ then it may now point to free'd memory 1N/A if the environment has been modified since. To avoid this 1N/A problem we treat env==NULL as meaning 'use the default' 1N/A#
endif /* USE_ENVIRON_ARRAY */ 1N/A#
endif /* !PERL_MICRO */ 1N/A /* touch @F array to prevent spurious warnings 20020415 MJD */ 1N/A /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */ 1N/A /* Treat PERL5?LIB as a possible search list logical name -- the 1N/A * "natural" VMS idiom for a Unix path string. We allow each 1N/A * element to be a set of |-separated directories for compatibility. 1N/A/* Use the ~-expanded versions of APPLLIB (undocumented), 1N/A ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB 1N/A /* sitearch is always relative to sitelib on Windows for 1N/A * DLL-based path intuition to work correctly */ 1N/A /* this picks up sitearch as well */ 1N/A /* vendorarch is always relative to vendorlib on Windows for 1N/A * DLL-based path intuition to work correctly */ 1N/A#
endif /* MACOS_TRADITIONAL */ 1N/A /* Break at all separators */ 1N/A /* skip any consecutive separators */ 1N/A /* Uncomment the next line for PATH semantics */ 1N/A /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */ 1N/A * BEFORE pushing libdir onto @INC we may first push version- and 1N/A * archname-specific sub-directories. 1N/A /* Configure terminates PERL_INC_VERSION_LIST with a NULL */ 1N/A "Failed to unixify @INC element \"%s\"\n",
1N/A /* .../version if -d .../version */ 1N/A /* .../archname if -d .../archname */ 1N/A /* .../xxx if -d .../xxx */ 1N/A /* finally push this lib directory on the end of @INC */ 1N/A /* thr->threadsvp is set when find_threadsv is called */ 1N/A /* Handcraft thrsv similarly to mess_sv */ 1N/A#
endif /* SET_THREAD_SELF */ 1N/A * These must come after the thread self setting 1N/A * because sv_setpvn does SvTAINT and the taint 1N/A * fields thread selfness being set. 1N/A#
endif /* USE_5005THREADS */ 1N/A /* save PL_beginav for compiler */ 1N/A /* save PL_checkav for compiler */ 1N/A "%s failed--call queue aborted",
1N/A /* my_exit() was called */