Pugs 6.2.13.9 → 6.2.13.10
raw patch · 7 files changed
+319/−3 lines, 7 files
Files
- Configure.PL +87/−0
- Pugs.cabal +7/−1
- perl5/p5embed.h +30/−0
- perl5/perlxsi.c +16/−0
- perl5/pugsembed.c +144/−0
- perl5/pugsembed.h +33/−0
- src/Pugs/Version.hs +2/−2
+ Configure.PL view
@@ -0,0 +1,87 @@+#!/usr/bin/perl++use 5.006;+use strict;+use Cwd;+use Config;+use ExtUtils::Embed;++my $embed_flags = "-I" . cwd();+my $ccdlflags = "";+my $flags = "$Config{ccflags} $Config{ccdlflags} ";++if ($flags =~ /\S/) {+ $flags =~ s{([\\"'])}{\\$1}g;+ my @flags = grep { length $_ } split /\s+/, $flags;++ if ($^O eq 'MSWin32') {+ if ($Config{libperl} =~ /lib(\w+)\.a/) {+ $embed_flags .= " -optl-l$1 ";+ }+ elsif (defined &Win32::BuildNumber) {+ # We are on ActivePerl -- Kluge massively!++ no warnings 'once';+ our %MY_CONFIG = %Config;+ *Config = *MY_CONFIG;+ *Config::Config = *MY_CONFIG;+ *ExtUtils::MM_Win32::Config = *MY_CONFIG;+ *ExtUtils::MM_Unix::Config = *MY_CONFIG;++ $Config{ccflags} =~ s/-libpath:"?(.*?)"? //g;+ $Config{ccdlflags} =~ s/-libpath:"?(.*?)"? //g;+ $Config{lddlflags} =~ s/-libpath:"?(.*?)"? //g;+ $Config{ldflags} =~ s/-libpath:"?(.*?)"? //g+ or die "ldflags: $Config{ldflags} does not contain -libpath:";++ my $lib = "$1/$Config{libperl}";+ $embed_flags .= " -optl\"$lib\" ";++ $flags = "$Config{ccflags} $Config{ccdlflags}";+ $flags =~ s{([\\"'])}{\\$1}g;+ @flags = grep { length $_ } split /\s+/, $flags;+ }+ else {+ warn "Unrecognized libperl shared library: $Config{libperl}, proceeding anyway...\n";+ }++ $ccdlflags .= (/^-[DIL]/ ? ' -optc' : ' -optl') . qq["$_" ] for @flags;+ $embed_flags .= " -optc-Ddirent=DIRENT";+ }+ else {+ $embed_flags .= " -optc$_" for grep length, split(/\s+/, ccopts());+ $embed_flags .= " -optl$_" for grep length, split(/\s+/, ldopts());+ }++ $embed_flags .= " $_" for grep { /-[DIL]/ } split(/\s+/, ccopts());+ $embed_flags .= " $_" for grep { /-[DIL]/ } split(/\s+/, ldopts());++ if ($Config{osname} eq 'cygwin') {+ my $cygpath = sub {+ my $path = `cygpath -m @_`;+ chomp $path;+ return $path;+ };+ $embed_flags =~ s{(/usr/\S+)}{$cygpath->($1)}eg;+ $embed_flags =~ s{/cygdrive/(\w)/}{$1:/}g;+ #warn "** Cygwin embedding flags: embed_flags\n";+ }+}++my @include_dirs = split(/\s+/, perl_inc());+s/^-I// for @include_dirs;++my @cc_options = map { /^-optc(.+)/ ? $1 : () } (split(/\s+/, $embed_flags), split(/\s+/, $ccdlflags));+my @ld_options = map { /^-optl(.+)/ ? $1 : () } (split(/\s+/, $embed_flags), split(/\s+/, $ccdlflags));++open INFO, ">Pugs.buildinfo" or die "Cannot write build info: $!";+print INFO << ".";+executable: pugs+ghc-options: $embed_flags $ccdlflags+include-dirs: @include_dirs+cc-options: @cc_options+ld-options: @ld_options+.+close INFO;++xsinit();
Pugs.cabal view
@@ -1,5 +1,5 @@ Name : Pugs-Version : 6.2.13.9+Version : 6.2.13.10 license : BSD3 license-file : LICENSE cabal-version : >= 1.2@@ -144,6 +144,12 @@ src/Pugs/Val/Capture.hs src/Pugs/Val/Code.hs src/Pugs/Version.hs+ Configure.PL+ perl5/p5embed.c+ perl5/p5embed.h+ perl5/perlxsi.c+ perl5/pugsembed.c+ perl5/pugsembed.h flag Perl5 description: Enable Perl 5 Embedding
+ perl5/p5embed.h view
@@ -0,0 +1,30 @@+#define dirent DIRENT+#define _INTPTR_T_DEFINED+#define _UINTPTR_T_DEFINED+#undef RETURN++#if defined(__OpenBSD__)+#define _P5EMBED_INIT _p5embed_init+#else+#define _P5EMBED_INIT __init+#endif++#include "EXTERN.h"+#include "perl.h"+#include "embed.h"++PerlInterpreter * perl5_init ( int argc, char **argv );+char * perl5_SvPV ( SV * sv );+int perl5_SvIV ( SV * sv );+double perl5_SvNV ( SV * sv );+bool perl5_SvTRUE ( SV * sv );+bool perl5_SvROK(SV *inv);+SV * perl5_newSVpvn ( char * pv, int len );+SV * perl5_newSViv ( int iv );+SV * perl5_newSVnv ( double iv );+SV ** perl5_apply(SV *sub, SV *inv, SV** args, void *env, int cxt);+bool perl5_can(SV *inv, char *subname);+SV * perl5_eval(char *code, void *env, int cxt);+SV * perl5_get_sv ( const char *name );+void perl5_finalize ( SV* sv );+SV * perl5_sv_undef ();
+ perl5/perlxsi.c view
@@ -0,0 +1,16 @@+#include <EXTERN.h>+#include <perl.h>++EXTERN_C void xs_init (pTHX);++EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);++EXTERN_C void+xs_init(pTHX)+{+ char *file = __FILE__;+ dXSUB_SYS;++ /* DynaLoader is a special case */+ newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);+}
+ perl5/pugsembed.c view
@@ -0,0 +1,144 @@+#include "pugsembed.h"+extern int _P5EMBED_INIT;++IV+pugs_tied ( SV *sv )+{+ const MAGIC *mg;+ const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)+ ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;++ if ((mg = SvTIED_mg(sv, how))) {+ SV *osv = SvTIED_obj(sv, mg);+ if (SvROK(osv)) {+ const char *pv = sv_reftype(SvRV(osv),TRUE);+ if (strncmp(pv, "pugs::", 6) == 0) {+ SV *derefSV = newSVpv("DEREF", 0);+ SV **rv;+ SV *stack[0];+ stack[0] = NULL;+ rv = perl5_apply(derefSV, osv, stack, NULL, G_SCALAR);+ if ((rv[0] == NULL) && SvROK(rv[1])) {+ return SvIV((SV*)SvRV(rv[1]));+ }+ }+ }+ }++ return 0;+}++Val *+pugs_SvToVal ( SV *sv )+{+ svtype ty = SvTYPE(sv);+ IV tmp = 0;++ if (sv_isa(sv, "pugs")) {+ tmp = SvIV((SV*)SvRV(sv));+ return ((Val *)tmp);+ }+ else if (SvROK(sv)) {+ if (tmp = pugs_tied(SvRV(sv))) {+ return ((Val *)tmp);+ }+ else {+ return pugs_MkSvRef(sv);+ }+ }+ else if (ty == SVt_NULL) {+ return pugs_UndefVal();+ }+ else if (SvNIOKp(sv) && (sv_len(sv) != 0)) {+ if (SvNOK(sv)) {+ return pugs_NvToVal(SvNVX(sv));+ }+ else {+ return pugs_IvToVal(SvIVX(sv));+ }+ }+ else if (SvPOKp(sv)) {+ STRLEN len = sv_len(sv);+ if (SvUTF8(sv)) {+ return pugs_PvnToValUTF8(SvPV_nolen(sv), (int)len);+ }+ else {+ return pugs_PvnToVal(SvPV_nolen(sv), (int)len);+ }+ }+ else {+ return pugs_MkSvRef(sv);+ }+}++SV *+pugs_MkValRef ( Val *val, char *typeStr )+{+ SV *sv = newSV(0);+ Val *isa[2];+ SV *stack[8];++ sv_setref_pv(sv, "pugs", val);++ if (!_P5EMBED_INIT) {+ fprintf(stderr, "MkValRef called before perl_init.\n");+ }++ isa[0] = NULL;++ /* fprintf(stderr, "query the type: got %s\n", typeStr); */++ if ((typeStr == NULL) || (*typeStr == '\0')) {+ SV *typeSV = pugs_Apply(pugs_PvnToVal("&WHAT", 5), val, isa, G_SCALAR);+ typeStr = SvPV_nolen(typeSV);+ }++ if ((typeStr != NULL) && (*typeStr != '\0')) {+ SV **rv;+ SV *typeSV = newSVpv(typeStr, 0);+ stack[0] = typeSV;+ stack[1] = NULL;+ rv = perl5_apply(newSVpv("can", 0), newSVpv("pugs::guts", 0), stack, NULL, G_SCALAR);+ if ((rv[0] == NULL) && SvTRUE( rv[1] )) {+ stack[0] = sv;+ rv = perl5_apply(typeSV, newSVpv("pugs::guts", 0), stack, NULL, G_SCALAR);+ if (rv[0] == NULL) {+ /* no error happened -- used the tied obj */+ sv = rv[1];+ }+ else {+ fprintf(stderr, "error in pugs::guts application on type: %s\n", typeStr);+ sv_dump(rv[0]);+ }+ }+ else {+ /* for scalar ref, should still turn into tied one */+#if PERL5_EMBED_DEBUG+ fprintf(stderr, "unknown type\n");+#endif+ }+ }++ return (sv);+}++Val *pugs_getenv ()+{+ SV** rv = hv_fetch(PL_modglobal, "PugsEnv", 7, 0);+ IV tmp;+ if (rv == NULL) {+ Perl_croak(aTHX_ "PugsEnv uninitialized; please call pugs_setenv() first. (hate software so much.)");+ }+ tmp = SvIV((SV*)SvRV(*rv));+ return ((Val *)tmp);+}++void pugs_setenv ( Val *env )+{+ SV *sv;+ if (env == NULL) { return; }++ sv = newSV(0);+ sv_setref_pv(sv, "pugs", env);+ hv_store(PL_modglobal, "PugsEnv", 7, sv, 0);+}
+ perl5/pugsembed.h view
@@ -0,0 +1,33 @@+#include "p5embed.h"+#include <HsFFI.h>++#ifndef SvPVutf8_nolen+#define SvPVutf8_nolen SvPV_nolen+#endif++#ifndef PugsValDefined+#define PugsValDefined 1+typedef HsStablePtr Val;+#endif++extern Val *pugs_Eval ( char *code );+extern SV *pugs_Apply ( Val *sub, Val *inv, Val **args, int cxt );++extern Val *pugs_UndefVal ();+extern Val *pugs_IvToVal ( IV iv );+extern Val *pugs_NvToVal ( NV iv );+extern Val *pugs_PvnToVal ( char *pv, int len );+extern Val *pugs_PvnToValUTF8 ( char *pv, int len );++extern Val *pugs_MkSvRef ( SV *sv );+extern SV *pugs_ValToSv ( Val *val );+extern IV pugs_ValToIv ( Val *val );+extern NV pugs_ValToNv ( Val *val );+extern char *pugs_ValToPv ( Val *val );++Val *pugs_SvToVal ( SV *sv );+SV *pugs_MkValRef ( Val *val, char *typeStr );++Val *pugs_getenv ();+void pugs_setenv ( Val *env );+
src/Pugs/Version.hs view
@@ -14,10 +14,10 @@ -- #include "pugs_version.h" #ifndef PUGS_VERSION-#define PUGS_VERSION "6.2.13.9"+#define PUGS_VERSION "6.2.13.10" #endif #ifndef PUGS_DATE-#define PUGS_DATE "July 25, 2008"+#define PUGS_DATE "July 26, 2008" #endif #ifndef PUGS_SVN_REVISION #define PUGS_SVN_REVISION 0