PAR-Packer-1.029/0000755000372000037200000000000012645223742013537 5ustar roderichroderichPAR-Packer-1.029/myldr/0000755000372000037200000000000012645223742014666 5ustar roderichroderichPAR-Packer-1.029/myldr/run_with_inc.pl0000644000372000037200000000047012550722346017713 0ustar roderichroderich#!perl use strict; use warnings; use File::Temp; $ENV{PAR_TMPDIR} = File::Temp::tempdir(TMPDIR => 1, CLEANUP => 1); # add -I options corresponding to @INC after the first element of @ARGV, # then execute it splice @ARGV, 1, 0, map { "-I$_" } @INC; system(@ARGV) == 0 or die "system(@ARGV) failed: $!\n"; PAR-Packer-1.029/myldr/encode_append.pl0000644000372000037200000000165212405041317020001 0ustar roderichroderich#!perl use strict; use warnings; # Used in myldr/Makefile.PL / myldr/Makefile. # This script appends the uuencoded contents of $ARGV[0] to the file # specified as $ARGV[1] as __DATA__ section. Any previous _DATA_ is replaced. # section. # # copyright 2006-2009, Steffen Mueller $/ = undef; my $usage = <; close $in; $contents =~ s/^__DATA__\r?\n.*\z//ms; open my $enc, '<', $encfile or die $!; binmode $enc; unlink $outfile; open my $out, '>', $outfile or die $!; binmode $out; print $out $contents; print $out "\n__DATA__\n"; print $out pack 'u', <$enc>; close $out; close $enc; PAR-Packer-1.029/myldr/Dynamic.in0000644000372000037200000000275511701600537016604 0ustar roderichroderichpackage PAR::StrippedPARL::Dynamic; use 5.008001; use strict; use warnings; our $VERSION = '0.958'; use base 'PAR::StrippedPARL::Base'; our $Data_Pos = tell DATA; =head1 NAME PAR::StrippedPARL::Dynamic - Data package containing a dynamic PARL =head1 SYNOPSIS # For details, see PAR::StrippedPARL::Base. PAR::StrippedPARL::Dynamic->write_parl($file) or die "Some error..."; =head1 DESCRIPTION This class is internal to PAR. Do not use it outside of PAR. This class is basically just a container for a dynamic binary PAR loader which doesn't include the PAR code like the F or F you are used to. If you're really curious, I'll tell you it is just a copy of the F (or F) file. The data is appended during the C phase of the PAR build process, but only if applicable: If you perl is static, you won't get the dynamic loader. If the binary data isn't appended during the build process, the class methods will return the empty list. =head1 CLASS METHODS Inherits the methods from L. =cut sub _data_pos { my $class = shift; return $Data_Pos; } =head1 AUTHORS Steffen Mueller Esmueller@cpan.orgE, Audrey Tang Ecpan@audreyt.orgE =head1 COPYRIGHT AND LICENSE Copyright 2006-2009 by Steffen Mueller Esmueller@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L =cut __DATA__ PAR-Packer-1.029/myldr/sha1.c.PL0000644000372000037200000002640212405041317016172 0ustar roderichroderich#!perl use strict; use warnings; use Config; (my $file = __FILE__) =~ s/\.PL$//; open my $fh, '>', $file or die "Could not open '$file' for writing: $!\n"; print $fh <<'EOH'; /* Borrowed by Alan Stewart in 2004 from SHA1.xs, part of Digest::SHA1 */ /* Digest::SHA1 by Gisle Aas Copyright 1999-2003, Uwe Hollerbach Copyright 1997 */ /* you can redistribute it and/or modify it under the same terms as Perl itself. */ /* $Id: SHA1.xs,v 1.11 2003/10/13 07:14:04 gisle Exp $ */ /* NIST Secure Hash Algorithm */ /* heavily modified by Uwe Hollerbach */ /* from Peter C. Gutmann's implementation as found in */ /* Applied Cryptography by Bruce Schneier */ /* Further modifications to include the "UNRAVEL" stuff, below */ /* This code is in the public domain */ #include /* Useful defines & typedefs */ EOH print $fh "#ifndef H_PERL\n"; printf $fh "typedef %s U8;\n", $Config{u8type}; printf $fh "#define BYTEORDER 0x%s\n", $Config{byteorder}; print $fh "#endif\n"; print $fh <<'EOF'; #if defined(U64TYPE) && (defined(USE_64_BIT_INT) || ((BYTEORDER != 0x1234) && (BYTEORDER != 0x4321))) typedef U64TYPE PAR_ULONG; # if BYTEORDER == 0x1234 # undef BYTEORDER # define BYTEORDER 0x12345678 # elif BYTEORDER == 0x4321 # undef BYTEORDER # define BYTEORDER 0x87654321 # endif #else # if (!defined(__GNUC__) || !defined(_WINNT_H) || defined(__MINGW32__)) typedef unsigned long PAR_ULONG; /* 32-or-more-bit quantity */ # endif #endif #define SHA_BLOCKSIZE 64 #define SHA_DIGESTSIZE 20 typedef struct { PAR_ULONG digest[5]; /* message digest */ PAR_ULONG count_lo, count_hi; /* 64-bit bit count */ U8 data[SHA_BLOCKSIZE]; /* SHA data buffer */ int local; /* unprocessed amount in data */ } SHA_INFO; /* UNRAVEL should be fastest & biggest */ /* UNROLL_LOOPS should be just as big, but slightly slower */ /* both undefined should be smallest and slowest */ #define SHA_VERSION 1 #define UNRAVEL /* #define UNROLL_LOOPS */ /* SHA f()-functions */ #define f1(x,y,z) ((x & y) | (~x & z)) #define f2(x,y,z) (x ^ y ^ z) #define f3(x,y,z) ((x & y) | (x & z) | (y & z)) #define f4(x,y,z) (x ^ y ^ z) /* SHA constants */ #define CONST1 0x5a827999L #define CONST2 0x6ed9eba1L #define CONST3 0x8f1bbcdcL #define CONST4 0xca62c1d6L /* truncate to 32 bits -- should be a null op on 32-bit machines */ #define T32(x) ((x) & 0xffffffffL) /* 32-bit rotate */ #define R32(x,n) T32(((x << n) | (x >> (32 - n)))) /* the generic case, for when the overall rotation is not unraveled */ #define FG(n) \ T = T32(R32(A,5) + f##n(B,C,D) + E + *WP++ + CONST##n); \ E = D; D = C; C = R32(B,30); B = A; A = T /* specific cases, for when the overall rotation is unraveled */ #define FA(n) \ T = T32(R32(A,5) + f##n(B,C,D) + E + *WP++ + CONST##n); B = R32(B,30) #define FB(n) \ E = T32(R32(T,5) + f##n(A,B,C) + D + *WP++ + CONST##n); A = R32(A,30) #define FC(n) \ D = T32(R32(E,5) + f##n(T,A,B) + C + *WP++ + CONST##n); T = R32(T,30) #define FD(n) \ C = T32(R32(D,5) + f##n(E,T,A) + B + *WP++ + CONST##n); E = R32(E,30) #define FE(n) \ B = T32(R32(C,5) + f##n(D,E,T) + A + *WP++ + CONST##n); D = R32(D,30) #define FT(n) \ A = T32(R32(B,5) + f##n(C,D,E) + T + *WP++ + CONST##n); C = R32(C,30) static void sha_transform(SHA_INFO *sha_info) { int i; U8 *dp; PAR_ULONG T, A, B, C, D, E, W[80], *WP; dp = sha_info->data; /* the following makes sure that at least one code block below is traversed or an error is reported, without the necessity for nested preprocessor if/else/endif blocks, which are a great pain in the nether regions of the anatomy... */ #undef SWAP_DONE #if BYTEORDER == 0x1234 #define SWAP_DONE /* assert(sizeof(PAR_ULONG) == 4); */ for (i = 0; i < 16; ++i) { T = *((PAR_ULONG *) dp); dp += 4; W[i] = ((T << 24) & 0xff000000) | ((T << 8) & 0x00ff0000) | ((T >> 8) & 0x0000ff00) | ((T >> 24) & 0x000000ff); } #endif #if BYTEORDER == 0x4321 #define SWAP_DONE /* assert(sizeof(PAR_ULONG) == 4); */ for (i = 0; i < 16; ++i) { T = *((PAR_ULONG *) dp); dp += 4; W[i] = T32(T); } #endif #if BYTEORDER == 0x12345678 #define SWAP_DONE /* assert(sizeof(PAR_ULONG) == 8); */ for (i = 0; i < 16; i += 2) { T = *((PAR_ULONG *) dp); dp += 8; W[i] = ((T << 24) & 0xff000000) | ((T << 8) & 0x00ff0000) | ((T >> 8) & 0x0000ff00) | ((T >> 24) & 0x000000ff); T >>= 32; W[i+1] = ((T << 24) & 0xff000000) | ((T << 8) & 0x00ff0000) | ((T >> 8) & 0x0000ff00) | ((T >> 24) & 0x000000ff); } #endif #if BYTEORDER == 0x87654321 #define SWAP_DONE /* assert(sizeof(PAR_ULONG) == 8); */ for (i = 0; i < 16; i += 2) { T = *((PAR_ULONG *) dp); dp += 8; W[i] = T32(T >> 32); W[i+1] = T32(T); } #endif #ifndef SWAP_DONE #error Unknown byte order -- you need to add code here #endif /* SWAP_DONE */ for (i = 16; i < 80; ++i) { W[i] = W[i-3] ^ W[i-8] ^ W[i-14] ^ W[i-16]; #if (SHA_VERSION == 1) W[i] = R32(W[i], 1); #endif /* SHA_VERSION */ } A = sha_info->digest[0]; B = sha_info->digest[1]; C = sha_info->digest[2]; D = sha_info->digest[3]; E = sha_info->digest[4]; WP = W; #ifdef UNRAVEL FA(1); FB(1); FC(1); FD(1); FE(1); FT(1); FA(1); FB(1); FC(1); FD(1); FE(1); FT(1); FA(1); FB(1); FC(1); FD(1); FE(1); FT(1); FA(1); FB(1); FC(2); FD(2); FE(2); FT(2); FA(2); FB(2); FC(2); FD(2); FE(2); FT(2); FA(2); FB(2); FC(2); FD(2); FE(2); FT(2); FA(2); FB(2); FC(2); FD(2); FE(3); FT(3); FA(3); FB(3); FC(3); FD(3); FE(3); FT(3); FA(3); FB(3); FC(3); FD(3); FE(3); FT(3); FA(3); FB(3); FC(3); FD(3); FE(3); FT(3); FA(4); FB(4); FC(4); FD(4); FE(4); FT(4); FA(4); FB(4); FC(4); FD(4); FE(4); FT(4); FA(4); FB(4); FC(4); FD(4); FE(4); FT(4); FA(4); FB(4); sha_info->digest[0] = T32(sha_info->digest[0] + E); sha_info->digest[1] = T32(sha_info->digest[1] + T); sha_info->digest[2] = T32(sha_info->digest[2] + A); sha_info->digest[3] = T32(sha_info->digest[3] + B); sha_info->digest[4] = T32(sha_info->digest[4] + C); #else /* !UNRAVEL */ #ifdef UNROLL_LOOPS FG(1); FG(1); FG(1); FG(1); FG(1); FG(1); FG(1); FG(1); FG(1); FG(1); FG(1); FG(1); FG(1); FG(1); FG(1); FG(1); FG(1); FG(1); FG(1); FG(1); FG(2); FG(2); FG(2); FG(2); FG(2); FG(2); FG(2); FG(2); FG(2); FG(2); FG(2); FG(2); FG(2); FG(2); FG(2); FG(2); FG(2); FG(2); FG(2); FG(2); FG(3); FG(3); FG(3); FG(3); FG(3); FG(3); FG(3); FG(3); FG(3); FG(3); FG(3); FG(3); FG(3); FG(3); FG(3); FG(3); FG(3); FG(3); FG(3); FG(3); FG(4); FG(4); FG(4); FG(4); FG(4); FG(4); FG(4); FG(4); FG(4); FG(4); FG(4); FG(4); FG(4); FG(4); FG(4); FG(4); FG(4); FG(4); FG(4); FG(4); #else /* !UNROLL_LOOPS */ for (i = 0; i < 20; ++i) { FG(1); } for (i = 20; i < 40; ++i) { FG(2); } for (i = 40; i < 60; ++i) { FG(3); } for (i = 60; i < 80; ++i) { FG(4); } #endif /* !UNROLL_LOOPS */ sha_info->digest[0] = T32(sha_info->digest[0] + A); sha_info->digest[1] = T32(sha_info->digest[1] + B); sha_info->digest[2] = T32(sha_info->digest[2] + C); sha_info->digest[3] = T32(sha_info->digest[3] + D); sha_info->digest[4] = T32(sha_info->digest[4] + E); #endif /* !UNRAVEL */ } /* initialize the SHA digest */ static void sha_init(SHA_INFO *sha_info) { sha_info->digest[0] = 0x67452301L; sha_info->digest[1] = 0xefcdab89L; sha_info->digest[2] = 0x98badcfeL; sha_info->digest[3] = 0x10325476L; sha_info->digest[4] = 0xc3d2e1f0L; sha_info->count_lo = 0L; sha_info->count_hi = 0L; sha_info->local = 0; } /* update the SHA digest */ static void sha_update(SHA_INFO *sha_info, U8 *buffer, int count) { int i; PAR_ULONG clo; clo = T32(sha_info->count_lo + ((PAR_ULONG) count << 3)); if (clo < sha_info->count_lo) { ++sha_info->count_hi; } sha_info->count_lo = clo; sha_info->count_hi += (PAR_ULONG) count >> 29; if (sha_info->local) { i = SHA_BLOCKSIZE - sha_info->local; if (i > count) { i = count; } memcpy(((U8 *) sha_info->data) + sha_info->local, buffer, i); count -= i; buffer += i; sha_info->local += i; if (sha_info->local == SHA_BLOCKSIZE) { sha_transform(sha_info); } else { return; } } while (count >= SHA_BLOCKSIZE) { memcpy(sha_info->data, buffer, SHA_BLOCKSIZE); buffer += SHA_BLOCKSIZE; count -= SHA_BLOCKSIZE; sha_transform(sha_info); } memcpy(sha_info->data, buffer, count); sha_info->local = count; } static void sha_transform_and_copy(unsigned char digest[20], SHA_INFO *sha_info) { sha_transform(sha_info); digest[ 0] = (unsigned char) ((sha_info->digest[0] >> 24) & 0xff); digest[ 1] = (unsigned char) ((sha_info->digest[0] >> 16) & 0xff); digest[ 2] = (unsigned char) ((sha_info->digest[0] >> 8) & 0xff); digest[ 3] = (unsigned char) ((sha_info->digest[0] ) & 0xff); digest[ 4] = (unsigned char) ((sha_info->digest[1] >> 24) & 0xff); digest[ 5] = (unsigned char) ((sha_info->digest[1] >> 16) & 0xff); digest[ 6] = (unsigned char) ((sha_info->digest[1] >> 8) & 0xff); digest[ 7] = (unsigned char) ((sha_info->digest[1] ) & 0xff); digest[ 8] = (unsigned char) ((sha_info->digest[2] >> 24) & 0xff); digest[ 9] = (unsigned char) ((sha_info->digest[2] >> 16) & 0xff); digest[10] = (unsigned char) ((sha_info->digest[2] >> 8) & 0xff); digest[11] = (unsigned char) ((sha_info->digest[2] ) & 0xff); digest[12] = (unsigned char) ((sha_info->digest[3] >> 24) & 0xff); digest[13] = (unsigned char) ((sha_info->digest[3] >> 16) & 0xff); digest[14] = (unsigned char) ((sha_info->digest[3] >> 8) & 0xff); digest[15] = (unsigned char) ((sha_info->digest[3] ) & 0xff); digest[16] = (unsigned char) ((sha_info->digest[4] >> 24) & 0xff); digest[17] = (unsigned char) ((sha_info->digest[4] >> 16) & 0xff); digest[18] = (unsigned char) ((sha_info->digest[4] >> 8) & 0xff); digest[19] = (unsigned char) ((sha_info->digest[4] ) & 0xff); } /* finish computing the SHA digest */ static void sha_final(unsigned char digest[20], SHA_INFO *sha_info) { int count; PAR_ULONG lo_bit_count, hi_bit_count; lo_bit_count = sha_info->count_lo; hi_bit_count = sha_info->count_hi; count = (int) ((lo_bit_count >> 3) & 0x3f); ((U8 *) sha_info->data)[count++] = 0x80; if (count > SHA_BLOCKSIZE - 8) { memset(((U8 *) sha_info->data) + count, 0, SHA_BLOCKSIZE - count); sha_transform(sha_info); memset((U8 *) sha_info->data, 0, SHA_BLOCKSIZE - 8); } else { memset(((U8 *) sha_info->data) + count, 0, SHA_BLOCKSIZE - 8 - count); } sha_info->data[56] = (U8)((hi_bit_count >> 24) & 0xff); sha_info->data[57] = (U8)((hi_bit_count >> 16) & 0xff); sha_info->data[58] = (U8)((hi_bit_count >> 8) & 0xff); sha_info->data[59] = (U8)((hi_bit_count >> 0) & 0xff); sha_info->data[60] = (U8)((lo_bit_count >> 24) & 0xff); sha_info->data[61] = (U8)((lo_bit_count >> 16) & 0xff); sha_info->data[62] = (U8)((lo_bit_count >> 8) & 0xff); sha_info->data[63] = (U8)((lo_bit_count >> 0) & 0xff); sha_transform_and_copy(digest, sha_info); } EOF close $fh; PAR-Packer-1.029/myldr/boot.c0000644000372000037200000001476112552715432016005 0ustar roderichroderich#undef readdir #ifdef _MSC_VER #include #else #include #include #endif #include "mktmpdir.c" typedef struct { size_t len; unsigned char *buf; } chunk_t; typedef struct { const char *name; size_t size; chunk_t *chunks; } embedded_file_t; #include "boot_embedded_files.c" #define EXTRACT_FAIL 0 #define EXTRACT_OK 1 #define EXTRACT_ALREADY 2 /* extract EMB_FILE to file STMPDIR/EXT_NAME and set *EXT_PATH to the latter; * return EXTRACT_ALREADY if the extracted file already exists (and has the * expected size), EXTRACT_OK if successful, EXTRACT_FAIL otherwise */ static int extract_embedded_file(embedded_file_t *emb_file, const char* ext_name, const char* stmpdir, char** ext_path) { int fd; chunk_t *chunk; struct stat statbuf; *ext_path = malloc(strlen(stmpdir) + 1 + strlen(ext_name) + 1); sprintf(*ext_path, "%s/%s", stmpdir, ext_name); fd = open(*ext_path, O_CREAT | O_EXCL | O_WRONLY | OPEN_O_BINARY, 0755); if ( fd == -1 ) { if ( errno != EEXIST ) return EXTRACT_FAIL; if (par_lstat(*ext_path, &statbuf) == 0 && statbuf.st_size == emb_file->size ) /* file already exists and has the expected size */ return EXTRACT_ALREADY; /* corrupted file? re-try writing it */ fd = open(*ext_path, O_CREAT | O_WRONLY | OPEN_O_BINARY, 0755); if ( fd == -1 ) return EXTRACT_FAIL; } chunk = emb_file->chunks; while (chunk->len) { if ( write(fd, chunk->buf, chunk->len) != chunk->len ) { return 0; } chunk++; } if (close(fd) == -1) return EXTRACT_FAIL; chmod(*ext_path, 0750); return EXTRACT_OK; } /* turn off automatic globbing of process arguments when using MingW */ #if defined(WIN32) && defined(__MINGW32__) int _CRT_glob = 0; #endif #ifdef WIN32 #define unpack_S(p) (*(WORD*)(p)) #define unpack_L(p) (*(DWORD*)(p)) #define ASSERT(expr, msg) if (!(expr)) fprintf(stderr, "assertion failed: %s\n", msg) /* seek file descriptor fd to member Subsystem (a WORD) of the * IMAGE_OPTIONAL_HEADER structure of a Windows executable * (so that the next 2 bytes read/written from/to fd get/set Subsystem); * cf. sub _fix_console in PAR/Packer.pm */ void seek_to_subsystem( int fd ) { BYTE buf[64]; DWORD off; WORD size, magic; lseek(fd, 0, SEEK_SET); // CHECK != -1 read(fd, buf, 64); // CHECK == 64 ASSERT(unpack_S(buf) == 0x5a4d, "MZ magic bytes"); // "MZ" off = unpack_L(buf+60); lseek(fd, off, SEEK_SET); // CHECK != -1 read(fd, buf, 4 + 20 + 2); // CHECK == 4 + 20 + 2 ASSERT(unpack_L(buf) == 0x4550, "PE header"); // "PE\0\0" size = unpack_S(buf+20); magic = unpack_S(buf+24); ASSERT(( size == 224 && magic == 0x10b ) || ( size == 240 && magic == 0x20b ), "IMAGE_NT_OPTIONAL_HDR_MAGIC"); lseek(fd, off + 4 + 20 + 68, SEEK_SET); // CHECK != -1 } #endif int main ( int argc, char **argv, char **env ) { int rc, i; char *stmpdir; embedded_file_t *emb_file; char *my_file; char *my_perl; char *my_prog; char buf[20]; /* must be large enough to hold "PAR_ARGV_###" */ #ifdef WIN32 typedef BOOL (WINAPI *pALLOW)(DWORD); HINSTANCE hinstLib; pALLOW ProcAdd; #ifndef ASFW_ANY #define ASFW_ANY -1 #endif #endif #define DIE exit(255) par_init_env(); stmpdir = par_mktmpdir( argv ); if ( !stmpdir ) DIE; /* error message has already been printed */ rc = my_mkdir(stmpdir, 0700); if ( rc == -1 && errno != EEXIST) { fprintf(stderr, "%s: creation of private cache subdirectory %s failed (errno= %i)\n", argv[0], stmpdir, errno); DIE; } /* extract embedded_files[0] (i.e. the custom Perl interpreter) * into stmpdir (but under the same basename as argv[0]) */ my_prog = par_findprog(argv[0], strdup(par_getenv("PATH"))); rc = extract_embedded_file(embedded_files, par_basename(my_prog), stmpdir, &my_perl); if (rc == EXTRACT_FAIL) { fprintf(stderr, "%s: extraction of %s (custom Perl interpreter) failed (errno=%i)\n", argv[0], my_perl, errno); DIE; } if (rc == EXTRACT_OK) /* i.e. file didn't already exist */ { #ifdef __hpux { /* HPUX will only honour SHLIB_PATH if the executable is specially marked */ char *chatr_cmd = malloc(strlen(my_perl) + 200); sprintf(chatr_cmd, "/usr/bin/chatr +s enable %s > /dev/null", my_perl); system(chatr_cmd); } #endif #ifdef WIN32 { /* copy IMAGE_OPTIONAL_HEADER.Subsystem (GUI vs console) * from this executable to the just extracted my_perl */ int fd; WORD subsystem; fd = open(my_prog, O_RDONLY | OPEN_O_BINARY, 0755); ASSERT(fd != -1, "open my_prog"); seek_to_subsystem(fd); read(fd, &subsystem, 2); // CHECK == 2 close(fd); // CHECK != -1 fd = open(my_perl, O_RDWR | OPEN_O_BINARY, 0755); ASSERT(fd != -1, "open my_perl"); seek_to_subsystem(fd); write(fd, &subsystem, 2); // CHECK == 2 close(fd); // CHECK != -1 } #endif } /* extract the rest of embedded_files into stmpdir */ emb_file = embedded_files + 1; while (emb_file->name) { if (extract_embedded_file(emb_file, emb_file->name, stmpdir, &my_file) == EXTRACT_FAIL) { fprintf(stderr, "%s: extraction of %s failed (errno=%i)\n", argv[0], my_file, errno); DIE; } emb_file++; } /* save original argv[] into environment variables PAR_ARGV_# */ sprintf(buf, "%i", argc); par_setenv("PAR_ARGC", buf); for (i = 0; i < argc; i++) { sprintf(buf, "PAR_ARGV_%i", i); par_unsetenv(buf); par_setenv(buf, argv[i]); } /* finally spawn the custom Perl interpreter */ #ifdef WIN32 hinstLib = LoadLibrary("user32"); if (hinstLib != NULL) { ProcAdd = (pALLOW) GetProcAddress(hinstLib, "AllowSetForegroundWindow"); if (ProcAdd != NULL) { (ProcAdd)(ASFW_ANY); } } par_setenv("PAR_SPAWNED", "1"); rc = spawnvpe(P_WAIT, my_perl, (char* const*)argv, (char* const*)environ); par_cleanup(stmpdir); exit(rc); #else execvp(my_perl, argv); DIE; #endif } PAR-Packer-1.029/myldr/winres/0000755000372000037200000000000012645223742016175 5ustar roderichroderichPAR-Packer-1.029/myldr/winres/pp.ico0000644000372000037200000001614611710320313017300 0ustar roderichroderichhF hV ( BBBnnnsssXXXkkkFFF qqq444555ZZZ mmm ///MMMDDDPPP<<<ddd222 AAAAAAAAAAAAAA5@#A1CAADE.<&5&"1  ".!. !"##%&'%EA   1A( @  !!!"""###$$$%%%&&&'''((()))***+++,,,---...///000111222333444555666777888999:::;;;<<<===>>>???@@@AAABBBCCCDDDEEEFFFGGGHHHIIIJJJKKKLLLMMMNNNOOOPPPQQQRRRSSSTTTUUUVVVWWWXXXYYYZZZ[[[\\\]]]^^^___```aaabbbcccdddeeefffggghhhiiijjjkkklllmmmnnnooopppqqqrrrssstttuuuvvvwwwxxxyyyzzz{{{|||}}}~~~444<<<<<<<<<<<<<<<<<<<<<, \Դ4Qd4QQd4QQQd4QQQQd쬌Ĕܼ4QQQQQdQdL4,\Qܼ4QQQQQQdQtlltܼ4dQԌtܤQܼ4d܌||ltܴ4\Ԝ\>>???@@@AAABBBCCCDDDEEEFFFGGGHHHIIIJJJKKKLLLMMMNNNOOOPPPQQQRRRSSSTTTUUUVVVWWWXXXYYYZZZ[[[\\\]]]^^^___```aaabbbcccdddeeefffggghhhiiijjjkkklllmmmnnnooopppqqqrrrssstttuuuvvvwwwxxxyyyzzz{{{|||}}}~~~444<<<<<<<<<<<<<<<<<<<<<, \Դ4Qd4QQd4QQQd4QQQQd쬌Ĕܼ4QQQQQdQdL4,\Qܼ4QQQQQQdQtlltܼ4dQԌtܤQܼ4d܌||ltܴ4\Ԝ\ CREATEPROCESS_MANIFEST_RESOURCE_ID RT_MANIFEST "winres\\pp.manifest" VS_VERSION_INFO VERSIONINFO FILEVERSION 0,0,0,0 PRODUCTVERSION 0,0,0,0 FILEFLAGSMASK VS_FFI_FILEFLAGSMASK FILEFLAGS PP_MANIFEST_FILEFLAGS FILEOS VOS_NT_WINDOWS32 FILETYPE VFT_APP FILESUBTYPE VFT2_UNKNOWN BEGIN BLOCK "StringFileInfo" BEGIN BLOCK "000004B0" BEGIN VALUE "CompanyName", " \0" VALUE "FileDescription", " \0" VALUE "FileVersion", "0.0.0.0\0" VALUE "InternalName", " \0" VALUE "LegalCopyright", " \0" VALUE "LegalTrademarks", " \0" VALUE "OriginalFilename", " \0" VALUE "ProductName", " \0" VALUE "ProductVersion", "0.0.0.0\0" END END BLOCK "VarFileInfo" BEGIN VALUE "Translation", 0x00, 0x04B0 END END WINEXE ICON winres\\pp.ico PAR-Packer-1.029/myldr/winres/pp.manifest0000644000372000037200000000147611710320313020334 0ustar roderichroderich PAR-Packer Application PAR-Packer-1.029/myldr/Makefile.PL0000644000372000037200000002720312550762211016636 0ustar roderichroderich#!perl # Copyright 2002-2009 by Audrey Tang. # Copyright (c) 2002 Mattia Barbon. # This package is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. use strict; use warnings; use Config; use File::Spec::Functions ':ALL'; use ExtUtils::Embed; use ExtUtils::MakeMaker; use DynaLoader; use File::Basename; use File::Glob; xsinit(undef); # used for searching libperls. sub find_file { my $file = shift; my @paths = ( $Config{bin}, catdir($Config{'archlibexp'}, 'CORE'), split(/\Q$Config{path_sep}\E/, $ENV{$Config{ldlibpthname}} || ''), split(/ /, $Config{libpth}), ); my $libperl; if ($libperl = DynaLoader::dl_findfile("-lperl")) { if (-l $libperl) { my $realpath = readlink($libperl); if (!file_name_is_absolute($realpath)) { $realpath = rel2abs(catfile(dirname($libperl), $realpath)); } $libperl = $realpath; } return $libperl if -e $libperl; } foreach my $path (@paths) { $libperl = catfile($path, $file); return $libperl if -e $libperl; # for MinGW $libperl = catfile($path, $1) if $file =~ /^lib(.+)/; return $libperl if -e $libperl; # for Cygwin $libperl = catfile($path, $file.$Config{_a}); return $libperl if -e $libperl; } } my $debug = $ENV{DEBUG}; my $chunk_size = 30000; my $exe = $Config{_exe}; my $link_exe = (($^O eq 'os2' and $Config{ldflags} =~ /-Zexe/) ? '' : $exe); my $o = $Config{obj_ext}; my $gccversion = $Config{gccversion}; # NOTE: on some platforms, ccopts or ldopts may contain newlines chomp( my $pccflags = ccopts() ); chomp( my $pldflags = ldopts() ); my $dynperl = $Config{useshrplib} && ($Config{useshrplib} ne 'false'); $dynperl = 1 if $pldflags =~ /\B-lperl\b/; # Gentoo lies to us! my $cc = $Config{cc}; my $ld = $Config{ld} || (($^O eq 'MSWin32') ? 'link.exe' : $Config{cc}); $ld = $Config{cc} if ($^O =~ /^(?:dec_osf|aix|hpux)$/); my $f2c = catfile('.', "file2c.pl"); my $par_pl = catfile('..', 'script', "par.pl"); my $par_exe = catfile('.', "par$exe"); my $par_exe_link = catfile('.', "par$link_exe"); my $boot_exe = catfile('.', "boot$exe"); my $boot_exe_link = catfile('.', "boot$link_exe"); my $parl_exe = "parl$exe"; my $parldyn_exe = "parldyn$exe"; my( $out, $ccdebug, $lddebug, $warn, $rm, $mv, $mt_cmd ); my $res = ''; my $res_section = ''; my $boot_ldflags = ''; if( $cc =~ m/^cl\b/i ) { $out = '-out:'; $ccdebug = $debug ? '-Zi -Zm1000 ' : '-Zm1000 '; $lddebug = $debug ? '-debug ' : '-release '; $warn = $debug ? '-W3' : ''; my $machinearch = ( $Config{ptrsize} == 8 ) ? 'AMD64' : 'X86'; $res = 'ppresource.obj'; $res_section = <<"..."; $res: rc winres\\pp.rc cvtres /NOLOGO /MACHINE:$machinearch /OUT:$res winres\\pp.res ... # Embed the manifest file for VC 2005 (aka VC8) or higher, but not for the # 64-bit Platform SDK compiler. if( $Config{ptrsize} == 4 and $Config{ccversion} =~ /^(\d+)/ and $1 >= 14 ) { $mt_cmd = 'mt -nologo -manifest $@.manifest -outputresource:$@;1'; } else { $mt_cmd = '-$(NOOP)'; } } elsif ($cc =~ m/\bgcc\b/i or ($cc =~ m/\bcc\b/i and $gccversion)) { $out = '-o '; $ccdebug = $debug ? '-g ' : ''; $lddebug = ($debug or $^O eq 'darwin') ? '' : '-s '; $warn = $debug ? '-Wall -Wno-comments ' : ''; if ( $^O =~ /^(?:MSWin|cygwin)/ ) { my $target = $Config{archname} =~ /x64/ ? 'pe-x86-64' : 'pe-i386'; $res = 'ppresource.coff'; # Note: On cygwin the command below will be processed by the # cygwin shell, so backslashes in pathnames might be a problem. # Instead use forward slashes which work on Windows as well. $res_section = <<"..."; $res: windres -i winres/pp.rc -o $res --input-format=rc --output-format=coff --target=$target ... } $mt_cmd = '-$(NOOP)'; $boot_ldflags .= '-static-libgcc ' if $^O eq 'MSWin32'; } else { $out = '-o '; $ccdebug = ''; $lddebug = ''; $warn = ''; $mt_cmd = '-$(NOOP)'; } my $perl58lib = ""; if($ENV{ACTIVEPERL_MINGW} and $Config{cf_email}=~/ActiveState.com/i){ $perl58lib = "-l$Config{libperl}"; $perl58lib =~ s/\.lib$//; } my $cflags = "$ccdebug$warn$pccflags"; my $optimize = $Config{optimize}; my $ldflags = "$lddebug$pldflags $perl58lib"; my $static_ldflags = $ldflags; my $libperl; if ($dynperl and $^O eq 'os2') { $libperl = OS2::DLLname(); } elsif ($dynperl) { my $file = $Config{libperl}; my $so = $Config{so} || 'so'; $file = "libperl.$so" if $file eq 'libper'; # workaround Red Hat bug $file =~ s/\.(?!\d)[^.]*$/.$Config{so}/; $file =~ s/^lib// if $^O eq 'MSWin32'; $libperl = find_file($file); if (not -e $libperl) { $file =~ s/\.(?!\d)[^.]*$/.a/; $libperl = find_file($file); } # die "Can't find $file in (@paths) -- please contact the author!" # unless -e $libperl; undef $dynperl if !-e $libperl; } my $perllibshortname = 'perl'; if ($dynperl) { $perllibshortname = basename($libperl); my $so = $Config{so} || 'so'; $perllibshortname =~ s/^lib//; $perllibshortname =~ s/\Q.$so\E$//; } $static_ldflags =~ s/(^|\s)-l$perllibshortname(\s|$)/ /g; $boot_ldflags .= $static_ldflags; # In the $dynperl case, we've already found the $libperl DSO. # The only problem is: when the linker links $par_exe against $libperl # we don't know what name is used to refer to $libperl in the executable # (e.g. on an ELF based system the DT_NEEDED tag). This is the name # the dynamic loader is looking for when $par_exe is executed. # # So we better make sure that $libperl is extracted using this name # during bootstrap of a packed executable. If we use the wrong name for # extraction, $libperl won't be considered by the dynamic loader. # This may cause the bootstrap to fail. Or the dynamic loader # might find a libperl DSO (e.g in /usr/lib using the built-in library # search path) from a Perl installation with the expected name. # However, this libperl may be ABI incompatible with $par_exe, # leading to hard to diagnose errors. # # Below we make a feeble attempt to determine this "link name" for some # well-known platforms. The fallback is always the basename of $libperl. # For ELF based systems the linker uses the DSO's DT_SONAME tag # as the link name if present. If the system uses the GNU binutils # toolchain we can use the objdump tool to find the DSO's soname. my $extract_libperl_as; if ($dynperl) { $extract_libperl_as = basename($libperl); if ($^O =~ /linux/i) { my ($soname) = qx(objdump -ax $libperl) =~ /^\s*SONAME\s+(\S+)/m; $extract_libperl_as = $soname if $? == 0 && defined $soname; } # on Debian derived distros make sure that the Debian package "libperl-dev" # is installed (which contains the /usr/lib/libperl.so symlink) die qq[You need to install the distro (Debian, Ubuntu etc) package "libperl-dev"\n] if $^O =~ /^(linux|gnukfreebsd)$/i && -x "/usr/bin/dpkg" # probably Debian or a derivative && system("dpkg -S $^X >/dev/null 2>&1") == 0 # we're building with the system (distro) perl && system("dpkg -l libperl-dev >/dev/null 2>&1") != 0; # check install status of libperl-dev } else { my $file = $Config{libperl}; $file = 'libperl.a' if $file eq 'libper'; # same redhat bug? Just making sure... $libperl = find_file($file); $ldflags = $static_ldflags; } my $par = (($dynperl && $^O ne 'os2') ? $boot_exe : $par_exe); # If on Windows and Perl was built with GCC 4.x, then libperl*.dll # may depend on some libgcc_*.dll (e.g. Strawberry Perl 5.12). # This libgcc_*.dll has to be included into with any packed executable # in the same way as libperl*.dll itself, otherwise a packed executable # won't run when libgcc_*.dll isn't installed. # The same holds for libstdc++*.dll (e.g. Strawberry Perl 5.16). sub find_dll { my ($dll_glob) = @_; # look for $dll_glob # - in the same directory as the perl executable itself # - in the same directory as gcc (only useful if it's an absolute path) # - in PATH my ($dll_path) = map { File::Glob::bsd_glob(catfile($_, $dll_glob)) } dirname($^X), dirname($cc), path(); return $dll_path; } my ($libgcc, $libstdcpp, $libwinpthread); if ($dynperl and $^O eq 'MSWin32' and defined $Config{gccversion} # gcc version >= 4.x was used and $Config{gccversion} =~ m{\A(\d+)}ms && $1 >= 4) { $libgcc = find_dll("libgcc_*.$Config{so}"); $libwinpthread = find_dll("libwinpthread*.$Config{so}"); } if ($ld =~ /(\b|-)g\+\+(-.*)?(\.exe)?$/) { # g++ was used to link $libstdcpp = find_dll("libstdc++*.$Config{so}"); } # enclose the filenames in double quotes # NOTE: This quoting is not perfect (e.g. won't protect dollar signs # or double quotes in filenames), but should work in all reasonable # scenarios on both *nix and Windows). my @embedded_files = map{ qq["$_"] } grep { defined } $par_exe, # must come first $libperl, $libgcc, $libwinpthread, $libstdcpp; my @strippedparl = qw( Static.pm ); push @strippedparl, qw( Dynamic.pm ) if $dynperl; my @parl_exes = $parl_exe; push @parl_exes, $parldyn_exe if $dynperl; # Determine whether we can find a config.h. If yes, include it in # usernamefrompwuid.h. If not, set I_PWD to undefined in that header. # -- Steffen my $configh = "$Config::Config{archlibexp}/CORE/config.h"; open PWOUT, '> usernamefrompwuid.h' or die "open 'usernamefrompwuid.h': $!"; if (not -f $configh) { print PWOUT "#undef I_PWD\n"; } else { print PWOUT "#include \"$configh\"\n"; } close PWOUT; WriteMakefile( NAME => "myldr", SKIP => [qw(static static_lib dynamic dynamic_lib test)], NO_META => 1, PL_FILES => {}, PM => { map { $_ => catfile('$(INST_LIBDIR)', qw( PAR StrippedPARL ), $_) } @strippedparl }, MAN1PODS => {}, EXE_FILES => \@parl_exes, macro => { FIXIN => '$(NOOP)' }, ); sub MY::postamble { my $make_frag = <<"EOT"; LD=$ld CC=$cc CFLAGS=$cflags -DPARL_EXE=\\"parl$exe\\" OPTIMIZE=$optimize LDFLAGS=$Config{ldflags} PERL_LDFLAGS=$ldflags STATIC_LDFLAGS=$static_ldflags OBJECTS=main$o $res MKTMP_STUFF=mktmpdir.c mktmpdir.h utils.c sha1.c .c$o: \$(CC) -c \$(CFLAGS) \$(OPTIMIZE) \$< pure_all:: $parl_exe Static.pm main$o: main.c my_par_pl.c perlxsi.c internals.c \$(MKTMP_STUFF) sha1.c: \$(PERLRUN) sha1.c.PL $res_section clean:: -\$(RM_F) boot_embedded_files.c my_par_pl.c -\$(RM_F) main$o boot$o $res -\$(RM_F) sha1.c -\$(RM_F) *.opt *.pdb perlxsi.c -\$(RM_F) usernamefrompwuid.h -\$(RM_F) $par_exe $boot_exe @parl_exes Dynamic.pm Static.pm $par_exe: \$(OBJECTS) \$(LD) \$(OBJECTS) \$(PERL_LDFLAGS) $out$par_exe_link $mt_cmd my_par_pl.c: $par_pl \$(PERLRUN) par_pl2c.pl my_par_pl < $par_pl > \$@ $parl_exe: $par \$(PERLRUN) -Mblib=.. run_with_inc.pl $par -q -B -O\$@ Static.pm: Static.in $par \$(PERLRUN) encode_append.pl Static.in $par Static.pm .DEFAULT: -\$(NOOP) .SUFFIXES: $o # dummy targets to satisfy ExtUtils::MakeMaker dynamic:: static:: test:: EOT $make_frag .= <<"EOT" if $dynperl; pure_all:: $parldyn_exe Dynamic.pm $parldyn_exe: $par_exe \$(PERLRUN) -Mblib=.. run_with_inc.pl $par_exe -q -B -O\$@ boot$o: \$(MKTMP_STUFF) boot_embedded_files.c $boot_exe: boot$o \$(LD) boot$o $boot_ldflags $res $out$boot_exe_link $mt_cmd boot_embedded_files.c: $par_exe \$(PERLRUN) $f2c -c $chunk_size @embedded_files > \$@ Dynamic.pm: Dynamic.in $par_exe \$(PERLRUN) encode_append.pl Dynamic.in $par_exe Dynamic.pm EOT return $make_frag; } # local variables: # mode: cperl # end: PAR-Packer-1.029/myldr/env.c0000644000372000037200000001140411701600537015613 0ustar roderichroderich/* * Copyright (c) 1987, 1993 * The Regents of the University of California. All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * 3. All advertising materials mentioning features or use of this software * must display the following acknowledgement: * This product includes software developed by the University of * California, Berkeley and its contributors. * 4. Neither the name of the University nor the names of its contributors * may be used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF * SUCH DAMAGE. */ #if defined(LIBC_SCCS) && !defined(lint) static const char sccsid[] = "@(#)getenv.c 8.1 (Berkeley) 6/4/93"; static const char sccsid[] = "@(#)setenv.c 8.1 (Berkeley) 6/4/93"; #endif /* LIBC_SCCS and not lint */ #include #include /* * __findenv -- * Returns pointer to value associated with name, if any, else NULL. * Sets offset to be the offset of the name/value combination in the * environmental array, for use by setenv(3) and unsetenv(3). * Explicitly removes '=' in argument name. * * This routine *should* be a static; don't use it. */ static char * __findenv(name, offset) register const char *name; int *offset; { extern char **environ; register int len; register const char *np; register char **p, *c; if (name == NULL || environ == NULL) return (NULL); for (np = name; *np && *np != '='; ++np) continue; len = np - name; for (p = environ; (c = *p) != NULL; ++p) #ifdef WIN32 if (strnicmp(c, name, len) == 0 && c[len] == '=') { #else if (strncmp(c, name, len) == 0 && c[len] == '=') { #endif *offset = p - environ; return (c + len + 1); } return (NULL); } static char * par_getenv(name) const char *name; { int i; return __findenv(name, &i); } /* * setenv -- * Set the value of the environmental variable "name" to be * "value". If rewrite is set, replace any current value. */ static int par_setenv(name, value) const char *name; register char *value; { extern char **environ; static int alloced = 0; /* if allocated space before */ register char *c; unsigned int l_value, offset; if (*value == '=') /* no `=' in value */ ++value; l_value = strlen(value); if ((c = __findenv(name, &offset))) { /* find if already exists */ if (strlen(c) >= l_value) { /* old larger; copy over */ while ((*c++ = *value++)); return (0); } } else { /* create new slot */ register int cnt; register char **p; for (p = environ, cnt = 0; *p; ++p, ++cnt); if (alloced) { /* just increase size */ environ = (char **)realloc((char *)environ, (size_t)(sizeof(char *) * (cnt + 2))); if (!environ) return (-1); } else { /* get new space */ alloced = 1; /* copy old entries into it */ p = malloc((size_t)(sizeof(char *) * (cnt + 2))); if (!p) return (-1); memmove(p, environ, cnt * sizeof(char *)); environ = p; } environ[cnt + 1] = NULL; offset = cnt; } for (c = (char *)name; *c && *c != '='; ++c); /* no `=' in name */ if (!(environ[offset] = /* name + `=' + value */ malloc((size_t)((int)(c - name) + l_value + 2)))) return (-1); for (c = environ[offset]; (*c = *name++) && *c != '='; ++c); for (*c++ = '='; (*c++ = *value++);); return (0); } /* * unsetenv(name) -- * Delete environmental variable "name". */ static void par_unsetenv(name) const char *name; { extern char **environ; register char **p; int offset; while (__findenv(name, &offset)) /* if set multiple times */ for (p = &environ[offset];; ++p) if (!(*p = *(p + 1))) break; } PAR-Packer-1.029/myldr/internals.c0000644000372000037200000000604312645201101017015 0ustar roderichroderichXS(XS_Internals_PAR_BOOT) { GV* tmpgv; AV* tmpav; SV** svp; SV* tmpsv; int i; int ok = 0; char *buf; TAINT; if (!(buf = par_getenv("PAR_INITIALIZED")) || buf[0] != '1' || buf[1] != '\0') { par_init_env(); } /* Remove the PAR/parl options from @ARGV */ if ((tmpgv = gv_fetchpv("ARGV", TRUE, SVt_PVAV))) {/* @ARGV */ tmpav = GvAV(tmpgv); for (i = 1; i < options_count; i++) { svp = av_fetch(tmpav, i-1, 0); if (!svp) break; if (strcmp(fakeargv[i], SvPV_nolen(*svp))) break; ok++; } if (ok == options_count - 1) { for (i = 1; i < options_count; i++) { tmpsv = av_shift(tmpav); } } } if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */ #ifdef WIN32 sv_setpv(GvSV(tmpgv),"perl.exe"); #else sv_setpv(GvSV(tmpgv),"perl"); #endif SvSETMAGIC(GvSV(tmpgv)); } if ((tmpgv = gv_fetchpv("0", TRUE, SVt_PV))) {/* $0 */ char *prog = NULL; if ( ( prog = par_getenv("PAR_PROGNAME") ) ) { sv_setpv(GvSV(tmpgv), prog); } else { #ifdef HAS_PROCSELFEXE S_procself_val(aTHX_ GvSV(tmpgv), fakeargv[0]); #else #ifdef OS2 sv_setpv(GvSV(tmpgv), os2_execname(aTHX)); #else prog = par_current_exec(); if( prog != NULL ) { sv_setpv( GvSV(tmpgv), prog ); free( prog ); } else { sv_setpv(GvSV(tmpgv), fakeargv[0]); } #endif #endif } #if (PERL_REVISION == 5 && PERL_VERSION == 8 \ && ( PERL_SUBVERSION >= 1 && PERL_SUBVERSION <= 5)) || \ (PERL_REVISION == 5 && PERL_VERSION == 9 && PERL_SUBVERSION <= 1) /* 5.8.1 through 5.8.5, as well as 5.9.0 does not copy fakeargv, sigh */ { char *p; STRLEN len = strlen( fakeargv[0] ); New( 42, p, len+1, char ); Copy( fakeargv[0], p, len, char ); SvSETMAGIC(GvSV(tmpgv)); Copy( p, fakeargv[0], len, char ); fakeargv[0][len] = '\0'; Safefree( p ); } /* #else SvSETMAGIC(GvSV(tmpgv)); */ #endif } TAINT_NOT; /* create temporary PAR directory */ stmpdir = par_getenv("PAR_TEMP"); if ( !stmpdir ) { stmpdir = par_mktmpdir( fakeargv ); if ( !stmpdir ) croak("Unable to create cache directory"); #ifndef WIN32 i = execvp(SvPV_nolen(GvSV(tmpgv)), fakeargv); croak("%s: execution of %s failed (errno=%i)\n", fakeargv[0], SvPV_nolen(GvSV(tmpgv)), i); return; #endif } i = PerlDir_mkdir(stmpdir, 0700); if ( (i != 0) && (i != EEXIST) && (i != -1) ) { croak("%s: creation of private cache subdirectory %s failed (errno=%i)\n", fakeargv[0], stmpdir, i); return; } } static void par_xs_init(pTHX) { xs_init(aTHX); newXSproto("Internals::PAR::BOOT", XS_Internals_PAR_BOOT, "", ""); } PAR-Packer-1.029/myldr/main.c0000644000372000037200000001032512246412626015755 0ustar roderichroderich#include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "perlxsi.c" #include "my_par_pl.c" /* Workaround for mapstart: the only op which needs a different ppaddr */ #undef Perl_pp_mapstart #define Perl_pp_mapstart Perl_pp_grepstart #undef OP_MAPSTART #define OP_MAPSTART OP_GREPSTART static PerlInterpreter *my_perl; static char *stmpdir; static int options_count; static char **fakeargv; #ifdef HAS_PROCSELFEXE /* This is a function so that we don't hold on to MAXPATHLEN bytes of stack longer than necessary */ STATIC void S_procself_val(pTHX_ SV *sv, char *arg0) { char buf[MAXPATHLEN]; int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1); /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe) includes a spurious NUL which will cause $^X to fail in system or backticks (this will prevent extensions from being built and many tests from working). readlink is not meant to add a NUL. Normal readlink works fine. */ if (len > 0 && buf[len-1] == '\0') len--; /* FreeBSD's implementation is acknowledged to be imperfect, sometimes returning the text "unknown" from the readlink rather than the path to the executable (or returning an error from the readlink). Any valid path has a '/' in it somewhere, so use that to validate the result. See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703 */ if (len > 0 && memchr(buf, '/', len)) sv_setpvn(sv, buf, len); else sv_setpv(sv,arg0); } #endif /* HAS_PROCSELFEXE */ #include "mktmpdir.c" #include "internals.c" int main ( int argc, char **argv, char **env ) { int exitstatus; int i; int argno = 0; #ifdef PERL_GPROF_MONCONTROL PERL_GPROF_MONCONTROL(0); #endif #ifdef PERL_SYS_INIT3 PERL_SYS_INIT3(&argc, &argv, &env); #endif #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && defined(HAS_PTHREAD_ATFORK) /* XXX Ideally, this should really be happening in perl_alloc() or * perl_construct() to keep libperl.a transparently fork()-safe. * It is currently done here only because Apache/mod_perl have * problems due to lack of a call to cancel pthread_atfork() * handlers when shared objects that contain the handlers may * be dlclose()d. This forces applications that embed perl to * call PTHREAD_ATFORK() explicitly, but if and only if it hasn't * been called at least once before in the current process. * --GSAR 2001-07-20 */ PTHREAD_ATFORK(Perl_atfork_lock, Perl_atfork_unlock, Perl_atfork_unlock); #endif if (!PL_do_undump) { my_perl = perl_alloc(); if (!my_perl) exit(1); perl_construct( my_perl ); PL_perl_destruct_level = 0; } #ifdef PERL_EXIT_DESTRUCT_END PL_exit_flags |= PERL_EXIT_DESTRUCT_END; #endif /* PERL_EXIT_DESTRUCT_END */ #ifdef PERL_EXIT_EXPECTED PL_exit_flags |= PERL_EXIT_EXPECTED; #endif /* PERL_EXIT_EXPECTED */ #if (defined(CSH) && defined(PL_cshname)) if (!PL_cshlen) PL_cshlen = strlen(PL_cshname); #endif #ifdef PERL_PROFILING #define PROFILING_OPTION 1 #else #define PROFILING_OPTION 0 #endif #ifdef ALLOW_PERL_OPTIONS #define EXTRA_OPTIONS 3 #else #define EXTRA_OPTIONS 4 #endif /* ALLOW_PERL_OPTIONS */ New(666, fakeargv, argc + EXTRA_OPTIONS + 1 + PROFILING_OPTION, char *); fakeargv[argno++] = argv[0]; #ifdef PERL_PROFILING fakeargv[argno++] = "-d:DProf"; #endif fakeargv[argno++] = "-e"; fakeargv[argno++] = my_par_pl; #ifndef ALLOW_PERL_OPTIONS fakeargv[argno++] = "--"; #endif /* ALLOW_PERL_OPTIONS */ options_count = argno; for (i = 1; i < argc; i++) fakeargv[i + options_count - 1] = argv[i]; fakeargv[argc + options_count - 1] = 0; exitstatus = perl_parse(my_perl, par_xs_init, argc + options_count - 1, fakeargv, (char **)NULL); if (exitstatus == 0) exitstatus = perl_run( my_perl ); perl_destruct( my_perl ); if ( par_getenv("PAR_SPAWNED") == NULL ) { if ( stmpdir == NULL ) stmpdir = par_getenv("PAR_TEMP"); if ( stmpdir != NULL ) par_cleanup(stmpdir); } perl_free( my_perl ); PERL_SYS_TERM(); return exitstatus; } PAR-Packer-1.029/myldr/file2c.pl0000644000372000037200000000432212405041317016356 0ustar roderichroderich#!perl # Copyright (c) 2002 Mattia Barbon. # Copyright (c) 2002 Audrey Tang. # This package is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. use strict; use warnings; use FindBin; use lib "$FindBin::Bin/../lib"; use File::Basename; use Getopt::Long; use IO::Compress::Gzip qw(gzip $GzipError); my $chunk_size = 30000; my $compress = 0; my $name; GetOptions( "c|chunk-size=i" => \$chunk_size, "z|compress" => \$compress) && @ARGV > 0 or die "Usage: $0 [-c CHUNK][-z] bin_file... > file.c\n"; binmode STDOUT; my $i = 0; my @embedded_files = map { process($i++, $_) } @ARGV; print "embedded_file_t embedded_files[] = {\n"; print " { \"$_->{name}\", $_->{size}, $_->{chunks} },\n" foreach @embedded_files; print " { NULL, 0, NULL }\n};"; exit 0; sub process { my ($i, $path) = @_; my $bin = do # a scalar reference { open my $in, "<", $path or die "open input file '$path': $!"; binmode $in; local $/ = undef; my $slurp = <$in>; close $in; \$slurp; }; if ($compress) { my $gzipped; my $status = gzip($bin, \$gzipped) or die "gzip failed: $GzipError\n"; $bin = \$gzipped; } my $len = length $$bin; my $chunk_count = int(( $len + $chunk_size - 1 ) / $chunk_size); my @chunks; for (my $j = 0; $j < $chunk_count; $j++) { push @chunks, { buf => "chunk_${i}_${j}", len => print_chunk( substr($$bin, $j * $chunk_size, $chunk_size), "chunk_${i}_${j}" ), }; } print "static chunk_t chunks_${i}[] = {\n"; print " { $_->{len}, $_->{buf} },\n" foreach @chunks; print " { 0, NULL } };\n\n"; return { name => basename($path), size => -s $path, chunks => "chunks_${i}", }; } sub print_chunk { my ($chunk, $name) = @_; my $len = length($chunk); print "static unsigned char ${name}[] = {\n"; for (my $i = 0; $i < $len; $i++) { printf "0x%02x,", ord(substr($chunk, $i, 1)); print "\n" if $i % 16 == 15; } print "};\n"; return $len; } # local variables: # mode: cperl # end: PAR-Packer-1.029/myldr/usernamefrompwuid.c0000644000372000037200000000141111701600537020574 0ustar roderichroderich#include "usernamefrompwuid.h" #ifdef I_PWD # include # include #endif /* This piece of code uses getpwuid from pwd.h to determine the current * user name. * Since pwd.h might not be available and perl's configure script probed * for this, we require access to perl's config.h. Whether or not we have that * can be determined by the Makefile.PL in myldr/. It writes the * usernamefrompwuid.h file for us. In the header, we include config.h if * available or sets I_PWD to undefined. * -- Steffen Mueller */ char *get_username_from_getpwuid () { char *username = NULL; #ifdef I_PWD struct passwd *userdata = NULL; userdata = getpwuid(getuid()); if (userdata) username = userdata->pw_name; #endif return(username); } PAR-Packer-1.029/myldr/par_pl2c.pl0000644000372000037200000000104612405041317016714 0ustar roderichroderich#!perl use strict; use warnings; use blib; # PAR::Filter::Podstrip might not be installed yet use PAR::Filter::PodStrip; my ($var) = @ARGV; my $slurp = do { local $/ = undef; }; PAR::Filter::PodStrip->new->apply(\$slurp); print "const char *$var =\n"; foreach (split(/\n/, $slurp)) { s/^\s*|\s*$//g; # strip leading and trailing whitespace next if /^#|^$/; # skip comment and empty lines s/(["\\])/\\$1/g; # escape quotes and backslashes print qq["$_\\n"\n]; } print ";\n" PAR-Packer-1.029/myldr/mktmpdir.h0000644000372000037200000000304711701600537016663 0ustar roderichroderich#ifdef _MSC_VER # define snprintf _snprintf # if _MSC_VER < 1500 # define vsnprintf _vsnprintf # endif # define strncasecmp _strnicmp # define strcasecmp _stricmp #endif #include #include #include #include #include #include #ifdef WIN32 # include # define Direntry_t struct direct # include #else # include # define Direntry_t struct dirent # include #endif #ifndef W_OK #define W_OK 0x02 #endif #ifndef X_OK #define X_OK 0x04 #endif #ifndef S_ISDIR # define S_ISDIR(m) ((m & S_IFMT) == S_IFDIR) #endif #ifndef S_ISLNK # ifdef _S_ISLNK # define S_ISLNK(m) _S_ISLNK(m) # else # ifdef _S_IFLNK # define S_ISLNK(m) ((m & S_IFMT) == _S_IFLNK) # else # ifdef S_IFLNK # define S_ISLNK(m) ((m & S_IFMT) == S_IFLNK) # else # define S_ISLNK(m) (0) # endif # endif # endif #endif #ifndef S_ISREG #define S_ISREG(x) 1 #endif #ifndef MAXPATHLEN #define MAXPATHLEN 32767 #endif #ifdef HAS_LSTAT #define par_lstat lstat #else #define par_lstat stat #endif #if defined(WIN32) || defined(OS2) static const char *dir_sep = "\\"; static const char *path_sep = ";"; #else static const char *dir_sep = "/"; static const char *path_sep = ":"; #endif #ifdef WIN32 # include # define my_mkdir(file, mode) _mkdir(file) #else # define my_mkdir(file, mode) mkdir(file,mode) #endif #include "utils.c" #include "sha1.c" #include "usernamefrompwuid.c" PAR-Packer-1.029/myldr/utils.c0000644000372000037200000001651111701600537016167 0ustar roderichroderich/* * Copyright (c) 1997 Todd C. Miller * * Permission to use, copy, modify, and distribute this software for any * purpose with or without fee is hereby granted, provided that the above * copyright notice and this permission notice appear in all copies. * * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. * */ #ifdef WIN32 # include #else # include #endif #include #include "env.c" #if defined __linux__ || defined __FreeBSD__ /* Look at /proc/$$/{exe,file} for the current executable Returns malloc()ed string. Caller must free. Returns NULL if can't be found. Note that FreeBSD has /proc unmounted by default. You'd think we could get this info via the kvm interface, but it turns out that to get kvm_getprocs()/kvm_read() to return any information we don't already have, we need read-access to /boot/kmem, which we don't have. And I couldn't get to work anyway. Email me (philip-at-pied.nu) if want a stab at the code. */ char *par_current_exec_proc( void ) { char proc_path[MAXPATHLEN + 1], link[MAXPATHLEN + 1]; char *ret = NULL; int n; n = sprintf( proc_path, "/proc/%i/%s", (int)getpid(), #if defined __FreeBSD__ "file" #else "exe" #endif ); if( n < 0 ) return NULL; n = readlink( proc_path, link, MAXPATHLEN); if( n < 0 ) return NULL; ret = (char *)malloc( n+1 ); if( ret == NULL ) return NULL; memcpy( ret, link, n ); ret[n] = '\0'; return ret; } #endif char *par_current_exec( void ) { #if defined __linux__ || defined __FreeBSD__ return par_current_exec_proc(); #else return NULL; #endif } char *par_findprog(char *prog, char *path) { char *p, filename[MAXPATHLEN]; /* char *ret; */ /* Commented out for reason described below */ int proglen, plen; char *par_temp = par_getenv("PAR_TEMP"); /* NOTE: This code is #include'd both from a plain C program (static.c) * and our custom Perl interpreter (main.c). In the latter case, * lstat() or stat() may be #define'd as calls into PerlIO and * expect &PL_statbuf as second parameter, rather than a pointer * to a struct stat. Try to distinguish these cases by checking * whether PL_statbuf is defined. */ #ifndef PL_statbuf struct stat PL_statbuf; #endif #ifdef WIN32 if ( GetModuleFileName(0, filename, MAXPATHLEN) ) { par_setenv("PAR_PROGNAME", filename); return strdup(filename); } #endif /* Special case if prog contains '/' */ if (strstr(prog, dir_sep)) { par_setenv("PAR_PROGNAME", prog); return(prog); } /* I'm commenting out this block because using par_current_exec_proc() * ends up breaking the PAR feature of inferring the script-to-be-run * from the name of the executable in case of symlinks because /proc/ * has the name of the executable and not that of the symlink. */ /* #if defined __linux__ || defined __FreeBSD__ ret = par_current_exec_proc(); #else ret = NULL; #endif if( ret != NULL ) { par_setenv( "PAR_PROGNAME", ret ); return ret; } */ /* Walk through PATH (path), looking for ourself (prog). This fails if we are invoked in an obscure manner; Basically, execvp( "/full/path/to/prog", "prog", NULL ) and "/full/path/to" isn't in $PATH. Of course, I can't think of a situation this will happen. */ proglen = strlen(prog); p = strtok(path, path_sep); while ( p != NULL ) { if (*p == '\0') p = "."; if ( par_temp != NULL && ( strcmp(par_temp, p) == 0 ) ) { p = strtok(NULL, path_sep); continue; } plen = strlen(p); /* strip trailing '/' */ while (p[plen-1] == *dir_sep) { p[--plen] = '\0'; } if (plen + 1 + proglen >= MAXPATHLEN) { par_setenv("PAR_PROGNAME", prog); return(prog); } sprintf(filename, "%s%s%s", p, dir_sep, prog); if ((stat(filename, &PL_statbuf) == 0) && S_ISREG(PL_statbuf.st_mode) && access(filename, X_OK) == 0) { par_setenv("PAR_PROGNAME", filename); return(strdup(filename)); } p = strtok(NULL, path_sep); } par_setenv("PAR_PROGNAME", prog); return(prog); } char *par_basename (const char *name) { const char *base = name; const char *p; for (p = name; *p; p++) { if (*p == *dir_sep) base = p + 1; } return (char *)base; } char *par_dirname (const char *path) { static char bname[MAXPATHLEN]; register const char *endp; /* Empty or NULL string gets treated as "." */ if (path == NULL || *path == '\0') { return(strdup(".")); } /* Strip trailing slashes */ endp = path + strlen(path) - 1; while (endp > path && *endp == *dir_sep) endp--; /* Find the start of the dir */ while (endp > path && *endp != *dir_sep) endp--; /* Either the dir is "/" or there are no slashes */ if (endp == path) { if (*endp == *dir_sep) { return strdup("."); } else { return strdup(dir_sep); } } else { do { endp--; } while (endp > path && *endp == *dir_sep); } if (endp - path + 2 > sizeof(bname)) { return(NULL); } strncpy(bname, path, endp - path + 1); return(bname); } void par_init_env () { char par_clean[] = "__ENV_PAR_CLEAN__ \0"; char *buf; /* ignore PERL5LIB et al. as they make no sense for a self-contained executable */ par_unsetenv("PERL5LIB"); par_unsetenv("PERLLIB"); par_unsetenv("PERL5OPT"); par_unsetenv("PERLIO"); par_unsetenv("PAR_INITIALIZED"); par_unsetenv("PAR_SPAWNED"); par_unsetenv("PAR_TEMP"); par_unsetenv("PAR_CLEAN"); par_unsetenv("PAR_DEBUG"); par_unsetenv("PAR_CACHE"); par_unsetenv("PAR_PROGNAME"); par_unsetenv("PAR_ARGC"); par_unsetenv("PAR_ARGV_0"); if ( (buf = par_getenv("PAR_GLOBAL_DEBUG")) != NULL ) { par_setenv("PAR_DEBUG", buf); } if ( (buf = par_getenv("PAR_GLOBAL_TMPDIR")) != NULL ) { par_setenv("PAR_TMPDIR", buf); } if ( (buf = par_getenv("PAR_GLOBAL_TEMP")) != NULL ) { par_setenv("PAR_TEMP", buf); } else if ( (buf = par_getenv("PAR_GLOBAL_CLEAN")) != NULL ) { par_setenv("PAR_CLEAN", buf); } else { buf = par_clean + 12 + strlen("CLEAN"); if (strncmp(buf, "PAR_CLEAN=", strlen("PAR_CLEAN=")) == 0) { par_setenv("PAR_CLEAN", buf + strlen("PAR_CLEAN=")); } } par_setenv("PAR_INITIALIZED", "1"); return; } int par_env_clean () { static int rv = -1; if (rv == -1) { char *buf = par_getenv("PAR_CLEAN"); rv = ( ((buf == NULL) || (*buf == '\0') || (*buf == '0')) ? 0 : 1); } return rv; } PAR-Packer-1.029/myldr/mktmpdir.c0000644000372000037200000002654111720726713016670 0ustar roderichroderich#include "mktmpdir.h" #define PAR_TEMP "PAR_TEMP" #ifdef O_BINARY # define OPEN_O_BINARY O_BINARY #else # define OPEN_O_BINARY 0 #endif #ifndef P_tmpdir #define P_tmpdir "/tmp" #endif /* NOTE: The code below is #include'd both from a plain C program (boot.c) * and our custom Perl interpreter (main.c). In the latter case, * lstat() or stat() may be #define'd as calls into PerlIO and * expect &PL_statbuf as second parameter, rather than a pointer * to a struct stat. Try to distinguish these cases by checking * whether PL_statbuf is defined. */ static int isWritableDir(const char* val) { #ifndef PL_statbuf struct stat PL_statbuf; #endif return par_lstat(val, &PL_statbuf) == 0 && ( S_ISDIR(PL_statbuf.st_mode) || S_ISLNK(PL_statbuf.st_mode) ) && access(val, W_OK) == 0; } #ifndef WIN32 /* check that: * - val is a directory (and not a symlink) * - val is owned by the user * - val has mode 0700 */ static int isSafeDir(const char* val) { #ifndef PL_statbuf struct stat PL_statbuf; #endif return par_lstat(val, &PL_statbuf) == 0 && S_ISDIR(PL_statbuf.st_mode) && PL_statbuf.st_uid == getuid() && (PL_statbuf.st_mode & 0777) == 0700; } #endif void par_setup_libpath( const char * stmpdir ) { const char *key = NULL , *val = NULL; int i; char *ld_path_env = NULL; /* NOTE: array is NULL terminated */ const char *ld_path_keys[] = { "LD_LIBRARY_PATH", "LIBPATH", "LIBRARY_PATH", "PATH", "DYLD_LIBRARY_PATH", "SHLIB_PATH", NULL }; for ( i = 0 ; key = ld_path_keys[i]; i++ ) { if ( (val = par_getenv(key)) == NULL || strlen(val) == 0 ) { par_setenv(key, stmpdir); } else if ( !strstr(val, stmpdir) ) { /* prepend stmpdir to (value of) environment variable */ ld_path_env = malloc( strlen(stmpdir) + strlen(path_sep) + strlen(val) + 1); sprintf( ld_path_env, "%s%s%s", stmpdir, path_sep, val); par_setenv(key, ld_path_env); } } } char *par_mktmpdir ( char **argv ) { int i; const char *tmpdir = NULL; const char *key = NULL , *val = NULL; /* NOTE: all arrays below are NULL terminated */ const char *temp_dirs[] = { P_tmpdir, #ifdef WIN32 "C:\\TEMP", #endif ".", NULL }; const char *temp_keys[] = { "PAR_TMPDIR", "TMPDIR", "TEMPDIR", "TEMP", "TMP", NULL }; const char *user_keys[] = { "USER", "USERNAME", NULL }; const char *subdirbuf_prefix = "par-"; const char *subdirbuf_suffix = ""; char *progname = NULL, *username = NULL; char *stmpdir = NULL, *top_tmpdir = NULL; int f, j, k, stmp_len = 0; char sha1[41]; SHA_INFO sha_info; unsigned char buf[32768]; unsigned char sha_data[20]; if ( (val = par_getenv(PAR_TEMP)) && strlen(val) ) { par_setup_libpath(val); return strdup(val); } #ifdef WIN32 { DWORD buflen = MAXPATHLEN; username = malloc(MAXPATHLEN); GetUserName((LPTSTR)username, &buflen); // FIXME this is uncondifionally overwritten below - WTF? } #endif /* Determine username */ username = get_username_from_getpwuid(); if ( !username ) { /* fall back to env vars */ for ( i = 0 ; username == NULL && (key = user_keys[i]); i++) { if ( (val = par_getenv(key)) && strlen(val) ) username = strdup(val); } } if ( username == NULL ) username = "SYSTEM"; /* sanitize username: encode all bytes as 2 hex digits */ { char *hexname = malloc(2 * strlen(username) + 1); char *u, *h; for ( u = username, h = hexname ; *u != '\0' ; u++, h += 2) sprintf(h, "%02x", *(unsigned char*)u); username = hexname; } /* Try temp environment variables */ for ( i = 0 ; tmpdir == NULL && (key = temp_keys[i]); i++ ) { if ( (val = par_getenv(key)) && strlen(val) && isWritableDir(val) ) { tmpdir = strdup(val); break; } } #ifdef WIN32 /* Try the windows temp directory */ if ( tmpdir == NULL && (val = par_getenv("WinDir")) && strlen(val) ) { char* buf = malloc(strlen(val) + 5 + 1); sprintf(buf, "%s\\temp", val); if (isWritableDir(buf)) { tmpdir = buf; } else { free(buf); } } #endif /* Try default locations */ for ( i = 0 ; tmpdir == NULL && (val = temp_dirs[i]) && strlen(val) ; i++ ) { if ( isWritableDir(val) ) { tmpdir = strdup(val); } } /* "$TEMP/par-$USER" */ stmp_len = strlen(tmpdir) + strlen(subdirbuf_prefix) + strlen(username) + strlen(subdirbuf_suffix) + 1024; /* stmpdir is what we are going to return; top_tmpdir is the top $TEMP/par-$USER, needed to build stmpdir. NOTE: We need 2 buffers because snprintf() can't write to a buffer it is also reading from. */ top_tmpdir = malloc( stmp_len ); sprintf(top_tmpdir, "%s%s%s%s", tmpdir, dir_sep, subdirbuf_prefix, username); #ifdef WIN32 _mkdir(top_tmpdir); /* FIXME bail if error (other than EEXIST) */ #else { if (mkdir(top_tmpdir, 0700) == -1 && errno != EEXIST) { fprintf(stderr, "%s: creation of private subdirectory %s failed (errno=%i)\n", argv[0], top_tmpdir, errno); return NULL; } if (!isSafeDir(top_tmpdir)) { fprintf(stderr, "%s: private subdirectory %s is unsafe (please remove it and retry your operation)\n", argv[0], top_tmpdir); return NULL; } } #endif stmpdir = malloc( stmp_len ); /* Doesn't really work - XXX */ val = par_getenv( "PATH" ); if (val != NULL) progname = par_findprog(argv[0], strdup(val)); if (progname == NULL) progname = argv[0]; /* If invoked as "/usr/bin/parl foo.par myscript.pl" then progname should * be ".../parl", and we don't want to base our checksum on that, but * rather on "foo.par". */ { #ifdef WIN32 #define STREQ(a,b) (strcasecmp(a,b) == 0) #else #define STREQ(a,b) (strcmp(a,b) == 0) #endif int prog_len = strlen(progname); int parl_len = strlen(PARL_EXE); if (prog_len >= parl_len && STREQ(progname + prog_len - parl_len, PARL_EXE) && (prog_len == parl_len || progname[prog_len - parl_len - 1] == dir_sep[0]) && argv[1] && strlen(argv[1]) >= 4 && STREQ(argv[1] + strlen(argv[1]) - 4, ".par")) progname = argv[1]; #undef STREQ } if ( !par_env_clean() && (f = open( progname, O_RDONLY | OPEN_O_BINARY ))) { lseek(f, -18, 2); read(f, buf, 6); if(buf[0] == 0 && buf[1] == 'C' && buf[2] == 'A' && buf[3] == 'C' && buf[4] == 'H' && buf[5] == 'E') { /* pre-computed cache_name in this file */ /* "$TEMP/par-$USER/cache-$cache_name" */ lseek(f, -58, 2); read(f, buf, 41); sprintf( stmpdir, "%s%scache-%s%s", top_tmpdir, dir_sep, buf, subdirbuf_suffix ); } else { /* "$TEMP/par-$USER/cache-$SHA1" */ lseek(f, 0, 0); sha_init( &sha_info ); while( ( j = read( f, buf, sizeof( buf ) ) ) > 0 ) { sha_update( &sha_info, buf, j ); } close( f ); sha_final( sha_data, &sha_info ); for( k = 0; k < 20; k++ ) { sprintf( sha1+k*2, "%02x", sha_data[k] ); } sha1[40] = '\0'; sprintf( stmpdir, "%s%scache-%s%s", top_tmpdir, dir_sep, sha1, subdirbuf_suffix ); } } else { int i = 0; /* "$TEMP/par-$USER/temp-$PID" */ par_setenv("PAR_CLEAN", "1"); sprintf( stmpdir, "%s%stemp-%u%s", top_tmpdir, dir_sep, getpid(), subdirbuf_suffix ); /* Ensure we pick an unused directory each time. If the directory already exists when we try to create it, bump a counter and try "$TEMP/par-$USER/temp-$PID-$i". This will guard against cases where a prior invocation crashed leaving garbage in a temp directory that might interfere. */ while (my_mkdir(stmpdir, 0700) == -1 && errno == EEXIST) { sprintf( stmpdir, "%s%stemp-%u-%u%s", top_tmpdir, dir_sep, getpid(), ++i, subdirbuf_suffix ); } } free(top_tmpdir); /* set dynamic loading path */ par_setenv(PAR_TEMP, stmpdir); par_setup_libpath( stmpdir ); return stmpdir; } #ifdef WIN32 static void par_rmtmpdir ( char *stmpdir ) { struct _finddata_t cur_file; int subsub_len; char *subsubdir; char *slashdot; long hFile; int tries = 0; HMODULE dll; if ((stmpdir == NULL) || !strlen(stmpdir)) return; subsub_len = strlen(stmpdir) + 258; subsubdir = malloc( subsub_len ); sprintf(subsubdir, "%s\\*.*", stmpdir); hFile = _findfirst( subsubdir, &cur_file ); if ( hFile == -1 ) return; do { if (!strstr(cur_file.name, "\\")) { sprintf(subsubdir, "%s\\%s", stmpdir, cur_file.name); } else { sprintf(subsubdir, "%s", cur_file.name); } if (!(slashdot = strstr(subsubdir, "\\.")) || (strcmp(slashdot,"\\.") && strcmp(slashdot,"\\.."))) { if ((cur_file.attrib & _A_SUBDIR)) { par_rmtmpdir( subsubdir ); } else { dll = GetModuleHandle(cur_file.name); tries = 0; while ( _unlink(subsubdir) && ( tries++ < 10 ) ) { if ( dll ) FreeLibrary(dll); }; } } } while ( _findnext( hFile, &cur_file ) == 0 ); _findclose(hFile); _rmdir(stmpdir); } #else static void par_rmtmpdir ( char *stmpdir ) { DIR *partmp_dirp; Direntry_t *dp; char *subsubdir = NULL; int subsub_len; struct stat stbuf; /* remove temporary PAR directory */ if (!stmpdir || !*stmpdir) return; partmp_dirp = opendir(stmpdir); if ( partmp_dirp == NULL ) return; while ( ( dp = readdir(partmp_dirp) ) != NULL ) { if ( strcmp (dp->d_name, ".") != 0 && strcmp (dp->d_name, "..") != 0 ) { subsub_len = strlen(stmpdir) + 1 + strlen(dp->d_name) + 1; subsubdir = malloc( subsub_len); sprintf(subsubdir, "%s/%s", stmpdir, dp->d_name); if (stat(subsubdir, &stbuf) != -1 && S_ISDIR(stbuf.st_mode)) { par_rmtmpdir(subsubdir); } else { unlink(subsubdir); } free(subsubdir); subsubdir = NULL; } } closedir(partmp_dirp); rmdir(stmpdir); } #endif void par_cleanup (char *stmpdir) { char *dirname = par_dirname(stmpdir); char *basename = par_basename(dirname); if ( par_env_clean() && stmpdir != NULL && strlen(stmpdir)) { if ( strstr(basename, "par-") == basename ) { par_rmtmpdir(stmpdir); /* Don't try to remove dirname because this will introduce a race with other applications that are trying to start. */ } } } PAR-Packer-1.029/myldr/Static.in0000644000372000037200000000263511701600537016444 0ustar roderichroderichpackage PAR::StrippedPARL::Static; use 5.008001; use strict; use warnings; our $VERSION = '0.958'; use base 'PAR::StrippedPARL::Base'; our $Data_Pos = tell DATA; =head1 NAME PAR::StrippedPARL::Static - Data package containing a static PARL =head1 SYNOPSIS # For details, see PAR::StrippedPARL::Base. PAR::StrippedPARL::Static->write_parl($file) or die "Some error..."; =head1 DESCRIPTION This class is internal to PAR. Do not use it outside of PAR. This class is basically just a container for a static binary PAR loader which doesn't include the PAR code like the F or F you are used to. If you're really curious, I'll tell you it is just a copy of the F (or F) file. The data is appended during the C phase of the PAR build process. If the binary data isn't appended during the build process, the class methods will return the empty list. =head1 CLASS METHODS Inherits the methods from L. =cut sub _data_pos { my $class = shift; return $Data_Pos; } =head1 AUTHORS Steffen Mueller Esmueller@cpan.orgE, Audrey Tang Ecpan@audreyt.orgE =head1 COPYRIGHT AND LICENSE Copyright 2006-2009 by Steffen Mueller Esmueller@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L =cut __DATA__ PAR-Packer-1.029/MANIFEST.SKIP0000644000372000037200000000120112467431130015421 0ustar roderichroderich#defaults ^\..*\.swp$ ^contrib/automated_pp_test/pp_switch_tests ^myldr/Makefile$ ^myldr/Makefile\.old$ ^myldr/MYMETA\. ^myldr/Dynamic.pm ^myldr/Static.pm ^myldr/boot$ ^myldr/boot_embedded_files.c ^myldr/x?static(?:.[^c].*)?$ ^myldr/my_.*$ ^myldr/parl ^myldr/perlxsi.c$ ^myldr/par(?:\.\w+)?$ ^myldr/pm_to_blib ^myldr/sha1.[co]$ ^myldr/usernamefrompwuid.h$ ^myldr/.*\.pdb$ ^myldr/usernamefrompwuid\.h$ ^package/parl-.*$ ^script/parl(?:\.(?!pod).+)?$ ^script/parldyn(?:\.(?!pod).+)?$ ^MANIFEST.bak$ ^Makefile$ ^Makefile.old$ ^MYMETA\. ^blib/ ^pm_to_blib ^blibdirs \B\.svn\b ^a\.out$ .*\.swp$ .*\.o$ .*\.obj$ .*\.exe$ ^nohup.out ^PAR-Packer-.* PAR-Packer-1.029/contrib/0000755000372000037200000000000012645223742015177 5ustar roderichroderichPAR-Packer-1.029/contrib/stdio/0000755000372000037200000000000012645223742016321 5ustar roderichroderichPAR-Packer-1.029/contrib/stdio/Stdio_readme.txt0000644000372000037200000000070711701600536021455 0ustar roderichroderichTk::Stdio is based on Tk::Stderr. This module provides an "on demand" console window, appearing only when standard IO is needed. As such, it is not just a PAR module, but is useful for any Perl executable generated without a normal DOS console. That could be a PAR package made with "pp -g" or a Perl script that intentionally closes the associated console to avoid having a DOS window hanging around. See the pod in the module for usage. Alan Stewart PAR-Packer-1.029/contrib/stdio/Stdio.pm0000644000372000037200000002554711701600536017746 0ustar roderichroderich##============================================================================== ## Tk::Stdio - capture program standard output and standard error, ## accept standard input ##============================================================================== ## Tk::Stdio is based on: ## ## Tk::Stderr - capture program standard error output ##============================================================================== require 5.006; package Tk::Stdio; use strict; use warnings; use vars qw($VERSION @ISA); ($VERSION) = q$Revision: 1.0 $ =~ /Revision:\s+(\S+)/ or $VERSION = "0.0"; use base qw(Tk::Derived Tk::MainWindow); use Tk::Text; use Tk::Frame; =pod =head1 NAME Tk::Stdio - capture standard output and error, accept standard input, display in separate window =head1 SYNOPSIS use Tk::Stdio; $mw = MainWindow->new->InitStdio; print "something\n"; ## goes to standard IO window print STDERR 'stuff'; ## likewise warn 'eek!'; ## likewise my $input = ; ## keyboard entry is in standard IO window my $char = getc; ## likewise =head1 DESCRIPTION This module captures the standard output or error of a program and redirects it to a read only text widget, which doesn't appear until necessary. When it does appear, the user can close it; it'll appear again when there is more output. Standard input can be entered in the widget, which becomes temporarily writable. =cut $Tk::Stdio::first_char = '1.0'; # 'line.char' set in READLINE or GETC ##============================================================================== ## Populate ##============================================================================== sub Populate { my ( $mw, $args ) = @_; my $private = $mw->privateData; $private->{ReferenceCount} = 0; $private->{Enabled} = 0; $mw->SUPER::Populate($args); $mw->withdraw; $mw->protocol( WM_DELETE_WINDOW => [ $mw => 'withdraw' ] ); my $f = $mw->Frame( Name => 'stderr_frame', )->pack( -fill => 'both', -expand => 1 ); my $text = $f->Scrolled( 'Text', -wrap => 'char', -scrollbars => 'oe', -state => 'disabled', -fg => 'white', -bg => 'black', -insertbackground => 'white', )->pack( -fill => 'both', -expand => 1 ); $text->bind( '