Permalink
Browse files

first commit; run perl6 t/mixer-channels.t and you get music+callbacks

  • Loading branch information...
1 parent c6eb76f commit 1770630028247afabee98823b4b73d27086053eb @FROGGS FROGGS committed Aug 24, 2012
Showing with 664 additions and 97 deletions.
  1. +0 −7 META.info
  2. +0 −24 README
  3. +0 −25 SDL.pl
  4. +277 −0 lib/NativeCall.pm6
  5. +0 −16 lib/SDL.pm
  6. +255 −0 lib/SDL.pm6
  7. +9 −0 lib/SDL/Mixer.pm6
  8. +14 −0 lib/SDL/Mixer/Channels.pm6
  9. +14 −0 lib/SDL/Mixer/Effects.pm6
  10. +13 −0 lib/SDL/Mixer/Samples.pm6
  11. +14 −0 lib/SDL/Version.pm6
  12. BIN sample.wav
  13. +0 −25 t/00-basic.t
  14. +26 −0 t/core.t
  15. +42 −0 t/mixer-channels.t
View
@@ -1,7 +0,0 @@
-{
- "name" : "SDL",
- "version" : "2011.06",
- "description" : "A Perl 6 NCI wrapper around SDL 1.2",
- "depends" : [ "Test::Mock" ],
- "source-url" : "git://github.com/PerlGameDev/SDL6.git"
-}
View
24 README
@@ -1,24 +0,0 @@
-Simple perl6 NCI usage for SDL.
-
-I made this work a few months ago at
-
-https://gist.github.com/744192
-
-Which was really no great feat.
-
-You will need
-
-https://github.com/jnthn/zavolaj
-
-and perl6
-
-WARNING!!!
-
-or if you have parrot 3.5 installed don't install
-
-https://github.com/jnthn/zavolaj
-
-
-
-
-
View
25 SDL.pl
@@ -1,25 +0,0 @@
-#!perl6
-# Install NativeCall.pm from http://github.com/jnthn/zavolaj.git
-# Copy libSDL-1.2.so or dll into local directory and
-# perl6 SDL.pl :D
-
-use v6;
-
-use NativeCall;
-
-class SDL_Surface is OpaquePointer;
-
-sub SDL_SetVideoMode( Int $width, Int $height, Int $bpp, Int $flags )
-
- returns SDL_Surface
-
- is native('libSDL') { }
-
-sub SDL_Quit()
- is native('libSDL') { }
-
-my $foo = SDL_SetVideoMode( 200, 200, 32, 0);
-
-sleep(2);
-
-SDL_Quit();
View
@@ -0,0 +1,277 @@
+module NativeCall;
+
+# Throwaway type just to get us some way to get at the NativeCall
+# representation.
+my class native_callsite is repr('NativeCall') { }
+
+# Maps a chosen string encoding to a type recognized by the native call engine.
+sub string_encoding_to_nci_type($enc) {
+ given $enc {
+ when 'utf8' { 'utf8str' }
+ when 'utf16' { 'utf16str' }
+ when 'ascii' { 'asciistr' }
+ default { die "Unknown string encoding for native call: $enc"; }
+ }
+}
+
+# Builds a hash of type information for the specified parameter.
+sub param_hash_for(Parameter $p, :$with-typeobj) {
+ my Mu $result := nqp::hash();
+ my $type := $p.type();
+ nqp::bindkey($result, 'typeobj', $type) if $with-typeobj;
+ if $type ~~ Str {
+ my $enc := $p.?native_call_encoded() || 'utf8';
+ nqp::bindkey($result, 'type', nqp::unbox_s(string_encoding_to_nci_type($enc)));
+ nqp::bindkey($result, 'free_str', nqp::unbox_i(1));
+ }
+ elsif $type ~~ Callable {
+ nqp::bindkey($result, 'type', nqp::unbox_s(type_code_for($p.type)));
+ my $info := param_list_for($p.sub_signature, :with-typeobj);
+ nqp::unshift($info, return_hash_for($p.sub_signature));
+ nqp::bindkey($result, 'callback_args', $info);
+ }
+ else {
+ nqp::bindkey($result, 'type', nqp::unbox_s(type_code_for($p.type)));
+ }
+ $result
+}
+
+# Builds the list of parameter information for a callback argument.
+sub param_list_for(Signature $sig, :$with-typeobj) {
+ my Mu $arg_info := nqp::list();
+ for $sig.params -> $p {
+ nqp::push($arg_info, param_hash_for($p, :with-typeobj($with-typeobj)))
+ }
+
+ $arg_info;
+}
+
+# Builds a hash of type information for the specified return type.
+sub return_hash_for(Signature $s) {
+ my Mu $result := nqp::hash();
+ my $returns := $s.returns;
+ if $returns ~~ Str {
+ my $enc := &r.?native_call_encoded() || 'utf8';
+ nqp::bindkey($result, 'type', nqp::unbox_s(string_encoding_to_nci_type($enc)));
+ nqp::bindkey($result, 'free_str', nqp::unbox_i(0));
+ }
+ # TODO: If we ever want to handle function pointers returned from C, this
+ # bit of code needs to handle that.
+ else {
+ nqp::bindkey($result, 'type',
+ $returns =:= Mu ?? 'void' !! nqp::unbox_s(type_code_for($returns)));
+ }
+ $result
+}
+
+# Gets the NCI type code to use based on a given Perl 6 type.
+my %type_map =
+ 'int8' => 'char',
+ 'int16' => 'short',
+ 'int32' => 'int',
+ 'int' => 'long',
+ 'Int' => 'longlong',
+ 'num32' => 'float',
+ 'num64' => 'double',
+ 'num' => 'double',
+ 'Num' => 'double',
+ 'Callable' => 'callback';
+sub type_code_for(Mu ::T) {
+ return %type_map{T.^name}
+ if %type_map.exists(T.^name);
+ return 'cstruct'
+ if T.REPR eq 'CStruct';
+ return 'cpointer'
+ if T.REPR eq 'CPointer';
+ return 'carray'
+ if T.REPR eq 'CArray';
+ die "Unknown type {T.^name} used in native call.\n" ~
+ "If you want to pass a struct, be sure to use the CStruct representation.\n" ~
+ "If you want to pass an array, be sure to use the CArray type.";
+}
+
+multi sub map_return_type(Mu $type) { Mu }
+multi sub map_return_type($type) {
+ $type === int8 || $type === int16 || $type === int32 || $type === int ?? Int !!
+ $type === num32 || $type === num64 || $type === num ?? Num !!
+ $type
+}
+
+my role NativeCallSymbol[Str $name] {
+ method native_symbol() { $name }
+}
+
+# This role is mixed in to any routine that is marked as being a
+# native call.
+my role Native[Routine $r, Str $libname] {
+ has int $!setup;
+ has native_callsite $!call is box_target;
+
+ method postcircumfix:<( )>($args) {
+ unless $!setup {
+ my Mu $arg_info := param_list_for($r.signature);
+ my str $conv = self.?native_call_convention || '';
+ my $realname =
+ !$libname.DEFINITE ?? "" !!
+ $libname ~~ /\.\w+$/ ?? $libname !!
+ "$libname$*VM<config><load_ext>";
+ nqp::buildnativecall(self,
+ nqp::unbox_s($realname), # library name
+ nqp::unbox_s(self.?native_symbol // $r.name), # symbol to call
+ nqp::unbox_s($conv), # calling convention
+ $arg_info,
+ return_hash_for($r.signature));
+ $!setup = 1;
+ }
+ nqp::nativecall(nqp::p6decont(map_return_type($r.returns)), self,
+ nqp::getattr(nqp::p6decont($args), Capture, '$!list'))
+ }
+}
+
+# Role for carrying extra calling convention information.
+my role NativeCallingConvention[$name] {
+ method native_call_convention() { $name };
+}
+
+# Role for carrying extra string encoding information.
+my role NativeCallEncoded[$name] {
+ method native_call_encoded() { $name };
+}
+
+# Expose an OpaquePointer class for working with raw pointers.
+my class OpaquePointer is export is repr('CPointer') { }
+
+# CArray class, used to represent C arrays.
+my class CArray is export is repr('CArray') {
+ method at_pos(CArray:D: $pos) { die "CArray cannot be used without a type" }
+
+ my role IntTypedCArray[::TValue] does Positional[TValue] {
+ multi method at_pos(::?CLASS:D \$arr: $pos) is rw {
+ Proxy.new:
+ FETCH => method () {
+ nqp::p6box_i(nqp::r_atpos_i($arr, nqp::unbox_i($pos.Int)))
+ },
+ STORE => method (int $v) {
+ nqp::r_bindpos_i($arr, nqp::unbox_i($pos.Int), $v);
+ self
+ }
+ }
+ multi method at_pos(::?CLASS:D \$arr: int $pos) is rw {
+ Proxy.new:
+ FETCH => method () {
+ nqp::p6box_i(nqp::r_atpos_i($arr, $pos))
+ },
+ STORE => method (int $v) {
+ nqp::r_bindpos_i($arr, $pos, $v);
+ self
+ }
+ }
+ }
+ multi method PARAMETERIZE_TYPE(Int:U $t) {
+ self but IntTypedCArray[$t.WHAT]
+ }
+
+ my role NumTypedCArray[::TValue] does Positional[TValue] {
+ multi method at_pos(::?CLASS:D \$arr: $pos) is rw {
+ Proxy.new:
+ FETCH => method () {
+ nqp::p6box_n(nqp::r_atpos_n($arr, nqp::unbox_i($pos.Int)))
+ },
+ STORE => method (num $v) {
+ nqp::r_bindpos_n($arr, nqp::unbox_i($pos.Int), $v);
+ self
+ }
+ }
+ multi method at_pos(::?CLASS:D \$arr: int $pos) is rw {
+ Proxy.new:
+ FETCH => method () {
+ nqp::p6box_n(nqp::r_atpos_n($arr, $pos))
+ },
+ STORE => method (num $v) {
+ nqp::r_bindpos_n($arr, $pos, $v);
+ self
+ }
+ }
+ }
+ multi method PARAMETERIZE_TYPE(Num:U $t) {
+ self but NumTypedCArray[$t.WHAT]
+ }
+
+ my role TypedCArray[::TValue] does Positional[TValue] {
+ multi method at_pos(::?CLASS:D \$arr: $pos) is rw {
+ Proxy.new:
+ FETCH => method () {
+ nqp::r_atpos($arr, nqp::unbox_i($pos.Int))
+ },
+ STORE => method ($v) {
+ nqp::r_bindpos($arr, nqp::unbox_i($pos.Int), nqp::p6decont($v));
+ self
+ }
+ }
+ multi method at_pos(::?CLASS:D \$arr: int $pos) is rw {
+ Proxy.new:
+ FETCH => method () {
+ nqp::r_atpos($arr, $pos)
+ },
+ STORE => method ($v) {
+ nqp::r_bindpos($arr, $pos, nqp::p6decont($v));
+ self
+ }
+ }
+ }
+ multi method PARAMETERIZE_TYPE(Mu:U $t) {
+ die "A C array can only hold integers, numbers, strings, CStructs, CPointers or CArrays (not $t.perl())"
+ unless $t === Str || $t.REPR eq 'CStruct' | 'CPointer' | 'CArray';
+ self but TypedCArray[$t.WHAT]
+ }
+}
+
+multi trait_mod:<is>(Routine $r, :$symbol!) is export {
+ $r does NativeCallSymbol[$symbol];
+}
+
+# Specifies that the routine is actually a native call, into the
+# current executable (platform specific) or into a named library
+multi trait_mod:<is>(Routine $r, :$native!) is export {
+ $r does Native[$r, $native === True ?? Str !! $native];
+}
+
+# Specifies the calling convention to use for a native call.
+multi trait_mod:<is>(Routine $r, :$nativeconv!) is export {
+ $r does NativeCallingConvention[$nativeconv];
+}
+
+# Ways to specify how to marshall strings.
+multi trait_mod:<is>(Parameter $p, :$encoded!) is export {
+ $p does NativeCallEncoded[$encoded];
+}
+multi trait_mod:<is>(Routine $p, :$encoded!) is export {
+ $p does NativeCallEncoded[$encoded];
+}
+
+class CStr is repr('CStr') {
+ my role Encoding[$encoding] {
+ method encoding() { $encoding }
+ }
+
+ multi method PARAMETERIZE_TYPE(Str:D $encoding) {
+ die "Unknown string encoding for native call: $encoding" if not $encoding eq any('utf8', 'utf16', 'ascii');
+ self but Encoding[$encoding];
+ }
+}
+
+role ExplicitlyManagedString {
+ has CStr $.cstr is rw;
+}
+
+multi explicitly-manage(Str $x is rw, :$encoding = 'utf8') is export {
+ $x does ExplicitlyManagedString;
+ $x.cstr = pir::repr_box_str__PsP(nqp::unbox_s($x), CStr[$encoding]);
+}
+
+#multi refresh($obj) is export {
+# nqp::nativecallrefresh($obj);
+# 1;
+#}
+
+# vim:ft=perl6
View
@@ -1,16 +0,0 @@
-use v6;
-use NativeCall;
-
-class SDL_Surface is OpaquePointer;
-
-
-sub SDL_SetVideoMode( Int $width, Int $height, Int $bpp, Int $flags )
-
- returns SDL_Surface
-
- is native('libSDL') { }
-
-sub SDL_Quit()
- is native('libSDL') { }
-
-
Oops, something went wrong.

0 comments on commit 1770630

Please sign in to comment.