PAR-Packer-1.049/0000755000372000037200000000000013474213040013530 5ustar roderichroderichPAR-Packer-1.049/myldr/0000755000372000037200000000000013474213040014657 5ustar roderichroderichPAR-Packer-1.049/myldr/run_with_inc.pl0000644000372000037200000000047012767333006017716 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.049/myldr/embed_files.pl0000644000372000037200000000543613170075524017470 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 Getopt::Long; use File::Basename; use IO::Compress::Gzip qw(gzip $GzipError); my $chunk_size = 32768; my $compress = 0; GetOptions( "c|chunk-size=i" => \$chunk_size, "z|compress" => \$compress) && @ARGV == 3 or die "Usage: $0 [-c CHUNK][-z] par method libperl > file.c\n"; my ($par, $method, $libperl) = @ARGV; print STDERR qq[# using method $method to find files to embed\n]; require "./find_files_to_embed/$method.pl"; my $files_to_embed = find_files_to_embed($par, $libperl); my $filenn = "file00"; # 100 files should be enough my @embedded; # par is always the first embedded file push @embedded, embed($filenn++, basename($par), $par); while (my ($name, $file) = each %$files_to_embed) { push @embedded, embed($filenn++, $name, $file); } print "static embedded_file_t embedded_files[] = {\n"; print " { \"$_->{name}\", $_->{size}, $_->{chunks} },\n" foreach @embedded; print " { NULL, 0, NULL }\n};"; exit 0; sub embed { my ($prefix, $name, $file) = @_; print STDERR qq[# embedding "$file" as "$name"\n]; return { name => $name, size => -s $file, chunks => file2c($prefix, $file) }; } sub file2c { my ($prefix, $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 $offset = 0, my $i = 0; $offset <= $len; $offset += $chunk_size, $i++) { my $name = "${prefix}_${i}"; push @chunks, { name => $name, len => print_chunk(substr($$bin, $offset, $chunk_size), $name), }; } print "static chunk_t ${prefix}[] = {\n"; print " { $_->{len}, $_->{name} },\n" foreach @chunks; print " { 0, NULL } };\n\n"; return $prefix; } sub print_chunk { my ($chunk, $name) = @_; my $len = length($chunk); print qq[static unsigned char ${name}[] =]; my $i = 0; do { print qq[\n"]; while ($i < $len) { printf "\\x%02x", ord(substr($chunk, $i++, 1)); last if $i % 16 == 0; } print qq["]; } while ($i < $len); print ";\n"; return $len; } # local variables: # mode: cperl # end: PAR-Packer-1.049/myldr/encode_append.pl0000644000372000037200000000227413047646276020026 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; # cf. Config.pm $contents .= sprintf <<'...', ($^V) x 2; $^V eq %vd or die sprintf("Perl (%%s) version (%%vd) doesn't match the version (%vd) ". "that PAR::Packer was built with; please rebuild PAR::Packer", $^X, $^V); 1; ... 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.049/myldr/Dynamic.in0000644000372000037200000000271213021033523016567 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 F. =cut __DATA__ PAR-Packer-1.049/myldr/boot.c0000644000372000037200000001774013472057302016004 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; int len = strlen(stmpdir) + 1 + strlen(ext_name); char *tmp_path; *ext_path = malloc(len + 1); sprintf(*ext_path, "%s/%s", stmpdir, ext_name); if (par_lstat(*ext_path, &statbuf) == 0 && statbuf.st_size == emb_file->size ) return EXTRACT_ALREADY; /* file already exists and has the expected size */ tmp_path = malloc(len + 1 + 20 + 1); /* 20 decimal digits should be enough to hold up to 2^64-1 */ sprintf(tmp_path, "%s.%lu", *ext_path, (unsigned long)getpid()); fd = open(tmp_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 EXTRACT_FAIL; chunk++; } if (close(fd) == -1) return EXTRACT_FAIL; chmod(tmp_path, 0750); if (rename(tmp_path, *ext_path) == -1) unlink(tmp_path); /* NOTE: The error presumably is something like ETXTBSY (scenario: * another process was faster at extraction *ext_path than us and is * already using it in some way); anyway, let's assume *ext_path * is "good" and clean up our copy. */ 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 } /* algorithm stolen from Win32::ShellQuote, in particular quote_literal() */ char* shell_quote(const char *src) { /* some characters from src may be replaced with two chars, * add enclosing quotes and trailing \0 */ char *dst = malloc(2 * strlen(src) + 3); const char *p = src; char *q = dst; char c; *q++ = '"'; /* opening quote */ while (c = *p) { if (c == '\\') { int n = strspn(p, "\\"); /* span of backslashes starting at p */ memcpy(q, p, n); /* copy the span */ q += n; if (p[n] == '\0' || p[n] == '"') /* span ends in quote or NUL */ { memcpy(q, p, n); /* copy the span once more */ q += n; } p += n; /* advance over the span */ continue; } if (c == '"') *q++ = '\\'; /* escape the following quote */ *q++ = c; p++; } *q++ = '"'; /* closing quote */ *q++ = '\0'; return dst; } #endif char pp_version_info[] = "@(#) Packed by PAR::Packer " PAR_PACKER_VERSION; int main ( int argc, char **argv, char **env ) { int rc; char *stmpdir; embedded_file_t *emb_file; char *my_file; char *my_perl; char *my_prog; #ifdef WIN32 typedef BOOL (WINAPI *pALLOW)(DWORD); HINSTANCE hinstLib; pALLOW ProcAdd; char **argp; #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++; } /* finally spawn the custom Perl interpreter */ argv[0] = my_perl; #ifdef WIN32 hinstLib = LoadLibrary("user32"); if (hinstLib != NULL) { ProcAdd = (pALLOW) GetProcAddress(hinstLib, "AllowSetForegroundWindow"); if (ProcAdd != NULL) { (ProcAdd)(ASFW_ANY); } } par_setenv("PAR_SPAWNED", "1"); /* quote argv strings if necessary, cf. Win32::ShellQuote */ for (argp = argv; *argp; argp++) { int len = strlen(*argp); if ( len == 0 || (*argp)[len-1] == '\\' || strpbrk(*argp, " \t\n\r\v\"") ) { *argp = shell_quote(*argp); } } rc = spawnvp(P_WAIT, my_perl, (char* const*)argv); par_cleanup(stmpdir); exit(rc); #else execvp(my_perl, argv); DIE; #endif } PAR-Packer-1.049/myldr/sha1.c0000644000372000037200000002472213445242575015703 0ustar roderichroderich/* 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 #include #include "sha1.h" /* Useful defines & typedefs */ typedef unsigned char U8; #if defined(U64TYPE) typedef U64TYPE ULONGx; # if BYTEORDER == 0x1234 # undef BYTEORDER # define BYTEORDER 0x12345678 # elif BYTEORDER == 0x4321 # undef BYTEORDER # define BYTEORDER 0x87654321 # endif #else typedef unsigned long ULONGx; /* 32-or-more-bit quantity */ #endif #define SHA_BLOCKSIZE 64 #define SHA_DIGESTSIZE 20 struct _SHA_INFO { ULONGx digest[5]; /* message digest */ ULONGx count_lo, count_hi; /* 64-bit bit count */ U8 data[SHA_BLOCKSIZE]; /* SHA data buffer */ int local; /* unprocessed amount in data */ }; /* 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; ULONGx 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(ULONGx) == 4); */ for (i = 0; i < 16; ++i) { T = *((ULONGx *) 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(ULONGx) == 4); */ for (i = 0; i < 16; ++i) { T = *((ULONGx *) dp); dp += 4; W[i] = T32(T); } #endif #if BYTEORDER == 0x12345678 #define SWAP_DONE /* assert(sizeof(ULONGx) == 8); */ for (i = 0; i < 16; i += 2) { T = *((ULONGx *) 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(ULONGx) == 8); */ for (i = 0; i < 16; i += 2) { T = *((ULONGx *) 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 */ SHA_INFO* sha_init() { SHA_INFO *sha_info = malloc(sizeof(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; return sha_info; } /* update the SHA digest */ void sha_update(SHA_INFO *sha_info, U8 *buffer, int count) { int i; ULONGx clo; clo = T32(sha_info->count_lo + ((ULONGx) count << 3)); if (clo < sha_info->count_lo) { ++sha_info->count_hi; } sha_info->count_lo = clo; sha_info->count_hi += (ULONGx) 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 */ void sha_final(unsigned char digest[20], SHA_INFO *sha_info) { int count; ULONGx 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); free(sha_info); } PAR-Packer-1.049/myldr/winres/0000755000372000037200000000000013474213040016166 5ustar roderichroderichPAR-Packer-1.049/myldr/winres/pp.ico0000644000372000037200000001614612767333006017322 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.049/myldr/winres/pp.manifest0000644000372000037200000000273213242335540020344 0ustar roderichroderich PAR-Packer Application PAR-Packer-1.049/myldr/Makefile.PL0000644000372000037200000002407013445242575016651 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; 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 = 32768; 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 $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: winres\\pp.rc winres\\pp.manifest 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 = 'if exist $@.manifest 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{ptrsize} == 8 ? '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: winres/pp.rc winres/pp.manifest 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) { if ($^O eq 'os2') { $libperl = OS2::DLLname(); } else { 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); } $dynperl = 0 if !-e $libperl; } } $static_ldflags =~ s/(^|\s)-l\S*perl\S*(\s|$)/ /g; $boot_ldflags .= " $static_ldflags"; if ($dynperl) { # 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); my @strippedparl = qw( Static.pm ); push @strippedparl, qw( Dynamic.pm ) if $dynperl; my @parl_exes = $parl_exe; push @parl_exes, $parldyn_exe if $dynperl; # configure sha1.c my $sha1_defines = qq[-DBYTEORDER=0x$Config{byteorder}]; $sha1_defines .= qq[ -DU64TYPE="$Config{u64type}"] if defined($Config{u64type}) && ($Config{use64bitint} eq "define" || length($Config{byteorder}) == 8); # 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)], VERSION_FROM => "../lib/PAR/Packer.pm", NO_MYMETA => 1, PL_FILES => {}, PM => { map { $_ => catfile('$(INST_LIBDIR)', qw( PAR StrippedPARL ), $_) } @strippedparl }, EXE_FILES => \@parl_exes, MAN1PODS => {}, MAN3PODS => {}, macro => { FIXIN => '$(NOOP)' }, ); sub MY::postamble { my $make_frag = <<"EOT"; LD=$ld CC=$cc CFLAGS=$cflags -DLDLIBPTHNAME=\\"$Config{ldlibpthname}\\" -DPARL_EXE=\\"parl$exe\\" -DPAR_PACKER_VERSION=\\"\$(VERSION)\\" OPTIMIZE=$optimize LDFLAGS=$Config{ldflags} PERL_LDFLAGS=$ldflags STATIC_LDFLAGS=$static_ldflags OBJECTS=main$o sha1$o $res MKTMP_STUFF=mktmpdir.c mktmpdir.h utils.c sha1.h .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$o: sha1.c sha1.h \$(CC) -c \$(CFLAGS) \$(OPTIMIZE) $sha1_defines sha1.c $res_section clean:: -\$(RM_F) boot_embedded_files.c my_par_pl.c -\$(RM_F) $(OBJECTS) -\$(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 if ($dynperl) { my $method; for ($^O) { # sane platforms: use "ldd" if (/linux|solaris|freebsd|openbsd|cygwin/i) { print STDERR qq[# using "ldd" to find shared libraries needed by $par_exe\n]; $method = "ldd"; last; } # Mac OS X: use "otool -L" if available # Note: old versions of otool don't accept --version if (/darwin/i && (qx(otool --version 2>&1) || qx(otool -h /bin/ls 2>&1), $? == 0)) { print STDERR qq[# using "otool -L" to find shared libraries needed by $par_exe\n]; $method = "otool"; last; } # Windows with Mingw toolchain: use "objdump" recursively if (/mswin32/i && (qx(objdump --version), $? == 0)) { print STDERR qq[# using "objdump" recursively to find DLLs needed by $par_exe\n]; $method = "recursive_objdump"; last; } # fallback print STDERR qq[# guessing what DLLs are needed by $par_exe\n]; $method = "guess"; } $make_frag .= <<"EOT"; 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 sha1$o \$(LD) boot$o sha1$o $boot_ldflags $res $out$boot_exe_link $mt_cmd boot_embedded_files.c: $par_exe \$(PERLRUN) embed_files.pl -c $chunk_size $par_exe $method "$libperl" > \$@ 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.049/myldr/env.c0000644000372000037200000001176613052333502015624 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 const char *value; { #ifdef WIN32 char* p = (char*)malloc((size_t)(strlen(name) + strlen(value) + 2)); if (!p) return (-1); sprintf(p, "%s=%s", name, value); _putenv(p); return (0); #else extern char **environ; static int alloced = 0; /* if allocated space before */ register char *c; size_t l_value; int 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); #endif } /* * unsetenv(name) -- * Delete environmental variable "name". */ static void par_unsetenv(name) const char *name; { #ifdef WIN32 par_setenv(name, ""); #else 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; #endif } PAR-Packer-1.049/myldr/internals.c0000644000372000037200000000610413472057302017030 0ustar roderichroderichXS(XS_Internals_PAR_BOOT) { GV* tmpgv; AV* tmpav; SV** svp; 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++) { SV* unused = 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 } /* PAR::Packer isn't included in a packed executable, but we provide * this scalar so that a packed script may refer to the version * of PAR::Packer it was built with. */ sv_setpv(get_sv("PAR::Packer::VERSION", GV_ADD), PAR_PACKER_VERSION); 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"); } 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); } } static void par_xs_init(pTHX) { xs_init(aTHX); newXSproto("Internals::PAR::BOOT", XS_Internals_PAR_BOOT, "", ""); } PAR-Packer-1.049/myldr/main.c0000644000372000037200000001037113257724705015767 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" /* turn off automatic globbing of process arguments when using MingW */ #if defined(WIN32) && defined(__MINGW32__) int _CRT_glob = 0; #endif 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 */ #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++] = (char *)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] = NULL; exitstatus = perl_parse(my_perl, par_xs_init, argc + options_count - 1, fakeargv, 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.049/myldr/usernamefrompwuid.c0000644000372000037200000000141112767333006020605 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.049/myldr/par_pl2c.pl0000644000372000037200000000150113467601516016726 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)) { # Note: We've already podstripped stdin (i.e. par.pl), but # the generated C string will be passed through argc to our # custom Perl interpreter. Some legacy OS platforms have really # small _POSIX_ARG_MAX values, hence squeeze some more bytes from it. s/^\s*|\s*$//g; # strip leading and trailing whitespace next if /^#|^$/; # skip comment (nad #line) and empty lines s/(["\\])/\\$1/g; # escape quotes and backslashes print qq["$_\\n"\n]; } print ";\n" PAR-Packer-1.049/myldr/find_files_to_embed/0000755000372000037200000000000013474213040020617 5ustar roderichroderichPAR-Packer-1.049/myldr/find_files_to_embed/otool.pl0000644000372000037200000000147213170075524022322 0ustar roderichroderich#!perl use strict; use warnings; use File::Basename; sub is_system_lib { shift =~ m{^/usr/lib|^/System/Library/} }; sub find_files_to_embed { my ($par, $libperl) = @_; my $dlls = otool($par); # weed out system libs (but exclude the shared perl lib) while (my ($name, $path) = each %$dlls) { delete $dlls->{$name} if is_system_lib($path) && basename($path) !~ /perl/; } return $dlls; } # NOTE: "otool -L" is NOT recursive, i.e. it's the equivalent # of "objdump -ax" or "readelf -d" on Linux, but NOT "ldd". # So perhaps a recursive method like the one for objdump below is in order. sub otool { my ($file) = @_; my $out = qx(otool -L $file); die qq["otool -L $file" failed\n] unless $? == 0; return { map { basename($_) => $_ } $out =~ /^ \s+ (\S+) /gmx }; } 1; PAR-Packer-1.049/myldr/find_files_to_embed/ldd.pl0000644000372000037200000000270713472057302021732 0ustar roderichroderich#!perl use strict; use warnings; sub is_system_lib; sub find_files_to_embed { my ($par, $libperl) = @_; if ($^O =~ /cygwin/i) { chomp(my $system_root = qx( cygpath --unix '$ENV{SYSTEMROOT}' )); print STDERR "### SystemRoot (as Unix path) = $system_root\n"; *is_system_lib = sub { shift =~ m{^/usr/bin/(?!cygcrypt\b)|^\Q$system_root\E/}i }; # NOTE: cygcrypt-0.dll is not (anymore) in the set of default Cygwin packages } else { *is_system_lib = sub { shift =~ m{^(?:/usr)?/lib(?:32|64)?/} }; } my $dlls = ldd($par); # weed out system libs (but exclude the shared perl lib) while (my ($name, $path) = each %$dlls) { delete $dlls->{$name} if is_system_lib($path) && $name !~ /perl/; } return $dlls; } sub ldd { my ($file) = @_; my $out = qx(ldd $file); die qq["ldd $file" failed\n] unless $? == 0; # NOTE: On older Linux/glibc (e.g. seen on Linux 3.2.0/glibc 2.13) # ldd prints a line like # linux-vdso.so.1 => (0x00007fffd2ff2000) # (without a pathname between "=>" and the address) # while newer versions omit "=>" in this case. my %dlls = $out =~ /^ \s* (\S+) \s* => \s* ( \/ \S+ ) /gmx; while (my ($name, $path) = each %dlls) { unless (-e $path) { warn qq[# ldd reported strange path: $path\n]; delete $dlls{$name}; next; } } return \%dlls; } 1; PAR-Packer-1.049/myldr/find_files_to_embed/recursive_objdump.pl0000644000372000037200000000336613170075524024721 0ustar roderichroderich#!perl use strict; use warnings; use File::Basename; use Cwd; use File::Spec; use DynaLoader; my $system_root = Cwd::abs_path($ENV{SystemRoot}); sub is_system_lib { Cwd::abs_path(shift) =~ m{^\Q$system_root\E/}i } sub find_files_to_embed { my ($par, $libperl) = @_; return recursive_objdump($par, dirname($^X)); } sub recursive_objdump { my ($path, @search_first_in) = @_; # NOTE: Looks like Perl on Windows (e.g. Strawberry) doesn't set # $Config{ldlibpthname} - one could argue that its value should be "PATH". # But even where it is defined (e.g. "LD_LIBRARY_PATH" on Linux) # DynaLoader *appends* (an appropriately split) # $ENV{$Config{ldlibpthname}} to its search path, @dl_library_path, # which is wrong in our context as we want it to be searched first. # Hence, provide our own value for @dl_library_path. local @DynaLoader::dl_library_path = (@search_first_in, File::Spec->path()); my %dlls; my %seen; my $walker; $walker = sub { my ($obj) = @_; return if $seen{lc $obj}++; my $out = qx(objdump -ax "$obj"); die "objdump failed: $!\n" unless $? == 0; foreach my $dll ($out =~ /^\s*DLL Name:\s*(\S+)/gm) { next if $dlls{lc $dll}; # already found my ($file) = DynaLoader::dl_findfile($dll) or next; $dlls{lc $dll} = $file; next if is_system_lib($file); # no need to recurse on a system library $walker->($file); # recurse } }; $walker->(Cwd::abs_path($path)); # weed out system libraries while (my ($name, $path) = each %dlls) { delete $dlls{$name} if is_system_lib($path); } return \%dlls; } 1; PAR-Packer-1.049/myldr/find_files_to_embed/guess.pl0000644000372000037200000000336513170075524022317 0ustar roderichroderich#!perl use strict; use warnings; use Config; use File::Glob; use File::Basename; use File::Spec; my $ld = $Config{ld} || (($^O eq 'MSWin32') ? 'link.exe' : $Config{cc}); $ld = $Config{cc} if ($^O =~ /^(?:dec_osf|aix|hpux)$/); sub find_files_to_embed { my ($par, $libperl) = @_; # If on Windows and Perl was built with GCC 4.x or higher, 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). my ($libgcc, $libstdcpp, $libwinpthread); if ($^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}"); } return { map { basename($_) => $_ } grep { defined } $libperl, $libgcc, $libwinpthread, $libstdcpp }; } 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(File::Spec->catfile($_, $dll_glob)) } dirname($^X), dirname($Config{cc}), File::Spec->path(); return $dll_path; } 1; PAR-Packer-1.049/myldr/sha1.h0000644000372000037200000000032513436531533015674 0ustar roderichroderichtypedef struct _SHA_INFO SHA_INFO; extern SHA_INFO* sha_init(); extern void sha_update(SHA_INFO *sha_info, unsigned char *buffer, int count); extern void sha_final(unsigned char digest[20], SHA_INFO *sha_info); PAR-Packer-1.049/myldr/mktmpdir.h0000644000372000037200000000306613436534303016672 0ustar roderichroderich#ifdef _MSC_VER # if _MSC_VER < 1900 # define snprintf _snprintf # endif # 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 "usernamefrompwuid.c" PAR-Packer-1.049/myldr/utils.c0000644000372000037200000001643213312016126016166 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 (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 pointer to a Stat_t as second parameter, rather than a pointer * to a struct stat. Try to distinguish these cases by checking * whether Stat_t is defined. */ #ifndef Stat_t #define Stat_t struct stat #endif Stat_t statbuf; #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, &statbuf) == 0) && S_ISREG(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"); 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.049/myldr/mktmpdir.c0000644000372000037200000002607413472057302016670 0ustar roderichroderich#include "mktmpdir.h" #include "sha1.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: This code 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 pointer to a Stat_t as second parameter, rather than a pointer * to a struct stat. Try to distinguish these cases by checking * whether Stat_t is defined. */ #ifndef Stat_t #define Stat_t struct stat #endif static int isWritableDir(const char* val) { Stat_t statbuf; return par_lstat(val, &statbuf) == 0 && ( S_ISDIR(statbuf.st_mode) || S_ISLNK(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) { Stat_t statbuf; return par_lstat(val, &statbuf) == 0 && S_ISDIR(statbuf.st_mode) && statbuf.st_uid == getuid() && (statbuf.st_mode & 0777) == 0700; } #endif void par_setup_libpath( const char * stmpdir ) { const char *val = NULL; char *ld_path = LDLIBPTHNAME; char *ld_path_env = NULL; if ( (val = par_getenv(ld_path)) == NULL || strlen(val) == 0 ) { par_setenv(ld_path, 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(ld_path, 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_info = sha_init(); 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; intptr_t 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; Stat_t 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.049/myldr/Static.in0000644000372000037200000000257213021033523016436 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 F. =cut __DATA__ PAR-Packer-1.049/MANIFEST.SKIP0000644000372000037200000000125413436535115015440 0ustar roderichroderich#defaults ^\..*\.swp$ ^contrib/automated_pp_test/pp_switch_tests ^inc/\.author/\.keep ^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/usernamefrompwuid.h$ ^myldr/.*\.pdb$ ^myldr/usernamefrompwuid\.h$ ^package/parl-.*$ ^script/parl(?:\.(?!pod).+)?$ ^script/parldyn(?:\.(?!pod).+)?$ ^Makefile$ ^Makefile.old$ ^META\. ^MYMETA\. ^blib/ ^pm_to_blib ^blibdirs \B\.svn\b \B\.git\b \B\.gitignore\b ^a\.out$ .*\.bak$ .*\.swp$ .*\.o$ .*\.obj$ .*\.exe$ ^nohup.out ^typescript ^PAR-Packer-.* PAR-Packer-1.049/contrib/0000755000372000037200000000000013474213040015170 5ustar roderichroderichPAR-Packer-1.049/contrib/stdio/0000755000372000037200000000000013474213040016312 5ustar roderichroderichPAR-Packer-1.049/contrib/stdio/Stdio_readme.txt0000644000372000037200000000070712767332650021473 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.049/contrib/stdio/Stdio.pm0000644000372000037200000002554712767332650017764 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( '