├── .gitignore ├── .travis.yml ├── CONTRIBUTORS.md ├── Makefile ├── README.md ├── build └── tools │ ├── build_chapters.pl │ └── build_latex.pl ├── chapter_00 └── chapter_00.pod ├── chapter_01 ├── XSFun │ ├── Makefile.PL │ ├── XSFun.xs │ ├── lib │ │ └── XSFun.pm │ ├── ppport.h │ └── t │ │ └── add_numbers.t └── chapter_01.pod ├── chapter_02 ├── XSFun │ ├── Makefile.PL │ ├── XSFun.xs │ ├── lib │ │ └── XSFun.pm │ ├── ppport.h │ └── t │ │ └── version.t └── chapter_02.pod ├── chapter_03 ├── Audio-Chromaprint │ ├── Chromaprint.xs │ ├── MANIFEST │ ├── Makefile.PL │ ├── lib │ │ └── Audio │ │ │ └── Chromaprint.pm │ ├── ppport.h │ └── t │ │ ├── leak.t │ │ └── version.t └── chapter_03.pod ├── chapter_04 ├── Audio-Chromaprint │ ├── Chromaprint.xs │ ├── MANIFEST │ ├── Makefile.PL │ ├── lib │ │ └── Audio │ │ │ └── Chromaprint.pm │ ├── ppport.h │ └── t │ │ ├── leak.t │ │ ├── new.t │ │ └── version.t └── chapter_04.pod ├── chapter_05 ├── Audio-Chromaprint │ ├── Chromaprint.xs │ ├── MANIFEST │ ├── Makefile.PL │ ├── lib │ │ └── Audio │ │ │ └── Chromaprint.pm │ ├── ppport.h │ └── t │ │ ├── leak.t │ │ ├── new.t │ │ └── version.t └── chapter_05.pod ├── chapter_06 ├── Audio-Chromaprint │ ├── Chromaprint.xs │ ├── MANIFEST │ ├── Makefile.PL │ ├── lib │ │ └── Audio │ │ │ └── Chromaprint.pm │ ├── ppport.h │ └── t │ │ ├── leak-pointer.t │ │ ├── leak.t │ │ ├── new.t │ │ └── version.t └── chapter_06.pod ├── chapter_07 ├── Audio-Chromaprint │ ├── Chromaprint.xs │ ├── MANIFEST │ ├── Makefile.PL │ ├── lib │ │ └── Audio │ │ │ └── Chromaprint.pm │ ├── ppport.h │ └── t │ │ ├── leak-pointer.t │ │ ├── leak.t │ │ ├── new.t │ │ └── version.t └── chapter_07.pod ├── chapter_08 ├── Audio-Chromaprint │ ├── Chromaprint.xs │ ├── MANIFEST │ ├── Makefile.PL │ ├── lib │ │ └── Audio │ │ │ └── Chromaprint.pm │ ├── ppport.h │ ├── t │ │ ├── leak-pointer.t │ │ ├── leak.t │ │ ├── new.t │ │ └── version.t │ └── typemap └── chapter_08.pod ├── skeleton ├── Audio-Chromaprint │ ├── Chromaprint.xs │ ├── MANIFEST │ ├── Makefile.PL │ ├── lib │ │ └── Audio │ │ │ └── Chromaprint.pm │ └── ppport.h └── XSFun │ ├── Makefile.PL │ ├── XSFun.xs │ ├── lib │ └── XSFun.pm │ ├── ppport.h │ └── t │ └── XSFun.t └── t ├── chapter_xs.t └── pod.t /.gitignore: -------------------------------------------------------------------------------- 1 | *.bs 2 | *.c 3 | *.o 4 | *.old 5 | *.swp 6 | MYMETA.* 7 | pm_to_blib 8 | blib/ 9 | build/pdf 10 | build/chapters 11 | chapter_*/*/Makefile 12 | chromaprint/ 13 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl 2 | sudo: true 3 | 4 | perl: 5 | - "5.24" 6 | - "5.22" 7 | - "5.20" 8 | - "5.18" 9 | - "5.16" 10 | - "5.14" 11 | 12 | install: 13 | - wget https://bitbucket.org/acoustid/chromaprint/downloads/chromaprint-1.2.tar.gz 14 | - tar -xvzf chromaprint-1.2.tar.gz 15 | - cd chromaprint-1.2 16 | - sudo apt-get install libboost-dev libavcodec-dev libavformat-dev libgtest-dev 17 | - cmake . && make && sudo make install 18 | - cd .. 19 | - cpanm --notest Pod::Checker Test::MemoryGrowth Test::Fatal 20 | 21 | script: 22 | - make test 23 | -------------------------------------------------------------------------------- /CONTRIBUTORS.md: -------------------------------------------------------------------------------- 1 | # Contributors 2 | 3 | The following people have provided patches or otherwise contributed to 4 | xs-fun (listed in alphabetical order): 5 | 6 | - Bulk88 7 | - Mattia Barbon 8 | - Paul Cochrane 9 | - Gideon Israel Dsouza 10 | - David Farrell 11 | - Rafael Garcia-Suarez 12 | - Alex Grehov 13 | - Eric Herman 14 | - Mikhail Ivanov 15 | - Alberto Luaces 16 | - Olivier Mengué 17 | - Steffen Mueller 18 | - Zakariyya Mughal 19 | - Сергей Романов 20 | - Andrei Vereha 21 | - Maxim Vuets 22 | - Sawyer X 23 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: clean 2 | 3 | # requires that Pod-PseudoPod-LaTeX is available in the parent directory of 4 | # the xs-fun directory, i.e. from within the xs-fun directory do: 5 | # $ cd .. 6 | # $ git clone https://github.com/chromatic/Pod-PseudoPod-LaTeX.git 7 | # $ cd xs-fun 8 | # to ensure that you can build the pdf 9 | pdf: 10 | perl build/tools/build_chapters.pl 11 | perl -I../Pod-PseudoPod-LaTeX/lib build/tools/build_latex.pl 12 | cd build/pdf && pdflatex xs-fun.tex && pdflatex xs-fun.tex 13 | 14 | test: 15 | prove -r t/ 16 | 17 | clean: 18 | rm -f build/pdf/*.pdf 19 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | XS Fun 2 | ====== 3 | 4 | Any XS guru will tell you XS is easy. I've heard this many times. While it may 5 | be true, I realized one thing: XS can be scary. 6 | 7 | The purpose of this guide is to make XS fun. Yes, fun. Try it out, if you won't 8 | feel as exhilarated as I do as you make your way up the stairs of XS 9 | knowledge, I will fully reimburse your tuition. 10 | 11 | Ground rules 12 | ------------ 13 | 14 | 1. We use a template instead of [`h2xs`](http://perldoc.perl.org/h2xs.html). 15 | 2. We do not bundle an additional C library. 16 | 3. We assume you have at least Perl 5.14.2. 17 | 18 | These are the best bits of advice I've received so far and they've proven 19 | to be crucial. 20 | 21 | `h2xs` is old and crufty, and thus far seems more like a hurdle. Instead, 22 | this guide includes a skeleton for each exercise that you can copy and use 23 | each time you start a new project. 24 | 25 | Bundling additional C libraries requires hacks with `ExtUtils::MakeMaker` 26 | (which is a war in and of itself), including tab character nightmares and 27 | additional recursive Makefiles. One way around the obvious "you need to have 28 | this library installed" problem is to provide an `Alien` package. This guide 29 | might go over it at some point but makes no promises. 30 | 31 | Eliminating the use of `h2xs` and bundling any C libraries we use (that 32 | we haven't written by ourselves) removes a lot of needless complexity. 33 | 34 | Perl 5.14.2 is prevalent enough to consider it a starting ground, though at 35 | this point it is not yet necessarily important. 36 | 37 | Relevant resources 38 | ------------------ 39 | 40 | * [perlxs](http://perldoc.perl.org/perlxs.html) (`perldoc perlxs`) 41 | * [perlapi](http://perldoc.perl.org/perlapi.html) (`perldoc perlapi`) 42 | 43 | More advanced or specialized resources 44 | -------------------------------------- 45 | 46 | * [General index](http://perldoc.perl.org/index-internals.html) 47 | * [perlxstypemap](http://perldoc.perl.org/perlxstypemap.html) (`perldoc perlxstypemap`) 48 | * [perlhack](http://perldoc.perl.org/perlhack.html) (`perldoc perlhack`) 49 | * [perlhacktips](http://perldoc.perl.org/perlhacktips.html) (`perldoc perlhacktips`) 50 | * [perlhacktut](http://perldoc.perl.org/perlhacktut.html) (`perldoc perlhacktut`) 51 | * [perlguts](http://perldoc.perl.org/perlguts.html) (`perldoc perlguts`) 52 | * [perlintern](http://perldoc.perl.org/perlintern.html) (`perldoc perlintern`) 53 | * [perlinterp](http://perldoc.perl.org/perlinterp.html) (`perldoc perlinterp`) 54 | * [perlcall](http://perldoc.perl.org/perlcall.html) (`perldoc perlcall`) 55 | * [perlsource](http://perldoc/perl.org/perlsource.html) (`perldoc perlsource`) 56 | -------------------------------------------------------------------------------- /build/tools/build_chapters.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use warnings; 4 | use strict; 5 | 6 | use Modern::Perl; 7 | use File::Spec::Functions qw( catfile catdir splitpath ); 8 | use File::Path 'mkpath'; 9 | 10 | exit main(); 11 | 12 | sub main { 13 | build_chapter_pseudopod(); 14 | 15 | return 0; 16 | } 17 | 18 | sub build_chapter_pseudopod { 19 | my $chapters_dir = catdir('build', 'chapters'); 20 | mkpath($chapters_dir) unless -d $chapters_dir; 21 | 22 | for my $pod_chapter ( get_chapter_list() ) { 23 | my $chapter_basename = (splitpath($pod_chapter))[-1]; 24 | my $pseudopod_chapter = catfile($chapters_dir, $chapter_basename); 25 | my $pseudopod = pod2pseudopod($pod_chapter); 26 | say "Writing '$pseudopod_chapter from $pod_chapter"; 27 | open my $fh, ">:encoding(utf8)", $pseudopod_chapter 28 | or die "Cannot write '$pseudopod_chapter': $!"; 29 | print $fh $pseudopod; 30 | close $fh; 31 | } 32 | } 33 | 34 | sub get_chapter_list { 35 | my $glob_path = catfile('chapter_??', 'chapter_??.pod'); 36 | 37 | return glob($glob_path); 38 | } 39 | 40 | sub pod2pseudopod { 41 | my $pod_path = shift; 42 | 43 | # the solution with decrement_head() and the eval inside the regex was 44 | # adapated from http://www.perlmonks.org/?node_id=503934 45 | my $text = read_file($pod_path); 46 | $text =~ s/^=head(\d)/decrement_head($1)/egm; 47 | return $text; 48 | } 49 | 50 | sub read_file { 51 | my $path = shift; 52 | open my $fh, "<:encoding(UTF-8)", $path or die "can't open $path: $!"; 53 | my $text = scalar do { local $/; <$fh>; }; 54 | close $fh; 55 | return $text; 56 | } 57 | 58 | sub decrement_head { 59 | my $head_level = shift; 60 | $head_level--; 61 | return '=head' . $head_level; 62 | } 63 | 64 | # vim: expandtab shiftwidth=4 softtabstop=4 65 | -------------------------------------------------------------------------------- /build/tools/build_latex.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use warnings; 4 | use strict; 5 | 6 | use Modern::Perl; 7 | use File::Spec::Functions qw( catfile catdir splitpath ); 8 | use File::Path 'mkpath'; 9 | use Pod::PseudoPod::LaTeX; 10 | 11 | exit main(); 12 | 13 | sub main { 14 | build_chapter_latex(); 15 | build_main_latex(); 16 | 17 | return 0; 18 | } 19 | 20 | sub build_chapter_latex { 21 | my $latex_output_dir = catdir('build', 'pdf'); 22 | mkpath($latex_output_dir) unless -d $latex_output_dir; 23 | 24 | for my $pod_chapter ( get_chapter_list() ) { 25 | my $latex_chapter = (splitpath($pod_chapter))[-1]; 26 | $latex_chapter =~ s/pod$/tex/; 27 | my $latex_chapter_path = catfile($latex_output_dir, $latex_chapter); 28 | 29 | say "Building $latex_chapter_path from $pod_chapter"; 30 | open my $fh, ">:encoding(utf8)", $latex_chapter_path 31 | or die "Can't write '$latex_chapter_path': $!"; 32 | my $parser = Pod::PseudoPod::LaTeX->new(); 33 | $parser->output_fh($fh); 34 | $parser->parse_file($pod_chapter); 35 | close $fh; 36 | } 37 | } 38 | 39 | sub build_main_latex { 40 | my $glob_path = catfile('build', 'pdf', 'chapter_??.tex'); 41 | my @latex_chapters = glob($glob_path); 42 | my $latex_main_file = catfile('build', 'pdf', 'xs-fun.tex'); 43 | 44 | my $preample =<<'EOT'; 45 | \documentclass[12pt,a4paper]{scrbook} 46 | \usepackage{fancyvrb} 47 | \usepackage{url} 48 | \usepackage{titleref} 49 | EOT 50 | 51 | my $header =<<'EOT'; 52 | \begin{document} 53 | \title{XS Fun} 54 | \author{Sawyer X} 55 | \maketitle 56 | 57 | \tableofcontents 58 | EOT 59 | 60 | my $footer = '\end{document}'; 61 | 62 | say "Building $latex_main_file"; 63 | open my $fh, ">:encoding(utf8)", $latex_main_file 64 | or die "Can't write '$latex_main_file': $!"; 65 | say $fh $preample; 66 | say $fh $header; 67 | for my $chapter ( @latex_chapters ) { 68 | $chapter = (splitpath($chapter))[-1]; 69 | say $fh '\input{', $chapter, '}'; 70 | } 71 | say $fh $footer; 72 | close $fh; 73 | } 74 | 75 | sub get_chapter_list { 76 | my $glob_path = catfile('build', 'chapters', 'chapter_??.pod'); 77 | 78 | return glob($glob_path); 79 | } 80 | 81 | # vim: expandtab shiftwidth=4 softtabstop=4 82 | -------------------------------------------------------------------------------- /chapter_00/chapter_00.pod: -------------------------------------------------------------------------------- 1 | =head1 Preparing the skeleton 2 | 3 | =head2 A Good Start 4 | 5 | Let's start by creating the basic layout for our module. 6 | 7 | Create a directory for the project called F. Enter the directory 8 | and begin creating the following files. 9 | 10 | =head3 XSFun.pm 11 | 12 | Create a directory called F and inside it create a file called 13 | F, content as follows: 14 | 15 | package XSFun; 16 | 17 | use strict; 18 | use warnings; 19 | use XSLoader; 20 | 21 | use Exporter 5.57 'import'; 22 | 23 | our $VERSION = '0.001'; 24 | our %EXPORT_TAGS = ( 'all' => [] ); 25 | our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); 26 | 27 | XSLoader::load('XSFun', $VERSION); 28 | 29 | 1; 30 | 31 | =head1 NAME 32 | 33 | XSFun - Learning XS the fun way 34 | 35 | L loads C libraries dynamically so they can be used in Perl. 36 | 37 | As soon as you C, it will load our XS code using L and 38 | make it available and known to Perl. 39 | 40 | =head3 Makefile.PL 41 | 42 | In the top-level directory create the F which will generate a 43 | proper F, content as follows: 44 | 45 | use 5.008005; 46 | use ExtUtils::MakeMaker; 47 | WriteMakefile( 48 | NAME => 'XSFun', 49 | VERSION_FROM => 'lib/XSFun.pm', 50 | PREREQ_PM => { 'Test::More' => 0, 'Exporter' => '5.57' }, 51 | ABSTRACT_FROM => 'lib/XSFun.pm', 52 | AUTHOR => 'You', 53 | LIBS => [''], 54 | DEFINE => '', 55 | INC => '-I.', 56 | OBJECT => '$(O_FILES)', 57 | ); 58 | 59 | =head3 ppport.h 60 | 61 | The F file (Perl/Pollution/Portability) contains a series of 62 | macros and, if explicitly requested, functions that allow XS modules to 63 | be built using older versions of Perl. 64 | 65 | Create it in the top-level directory with the following command: 66 | 67 | perl -MDevel::PPPort -E'Devel::PPPort::WriteFile' 68 | 69 | Or on Windows cmd.exe with Strawberry Perl: 70 | 71 | perl -MDevel::PPPort -E"Devel::PPPort::WriteFile" 72 | 73 | =head3 XSFun.xs 74 | 75 | The XS file contains both XS code and possibly valid C code. At first we 76 | will insert C code into it, but with time we will use it to connect to 77 | existing libraries. 78 | 79 | If you want to optimize something, you can simply implement it directly in 80 | the XS file. If you want to connect to another library, you will use the 81 | XS code in order to glue together an existing library and Perl. 82 | 83 | Create the file F in the top-level directory with the following content: 84 | 85 | #define PERL_NO_GET_CONTEXT 86 | #include "EXTERN.h" 87 | #include "perl.h" 88 | #include "XSUB.h" 89 | #include "ppport.h" 90 | 91 | /* C functions */ 92 | 93 | MODULE = XSFun PACKAGE = XSFun 94 | 95 | # XS code 96 | 97 | The first line changes the compiled C code so it does not fetch the 98 | context every time it calls a Perl API function. This will make the 99 | code more efficient at the cost of being aware of MULTIPLICITY and 100 | threads. While this is a somewhat vague description, it should 101 | generally be used as it will make your XS code faster when run 102 | under threaded perls, without any additional work, I 103 | you define helper C functions in your XS file (and even in that case 104 | the additional work is minimal), which is good enough for us to add 105 | it. It's considered a modern XS practice. 106 | 107 | The next three lines are XS headers. The last include line uses the portability 108 | layer of F. After that we can insert any C code we want. Then, 109 | we give enough XS information to connect this XS file to our Perl code. 110 | Afterwards we can provide more advanced XS functionality. 111 | 112 | From this point on we will use this setup as our skeleton. You can save it 113 | separately and copy it over in every new chapter. 114 | -------------------------------------------------------------------------------- /chapter_01/XSFun/Makefile.PL: -------------------------------------------------------------------------------- 1 | use 5.008005; 2 | use ExtUtils::MakeMaker; 3 | WriteMakefile( 4 | NAME => 'XSFun', 5 | VERSION_FROM => 'lib/XSFun.pm', 6 | PREREQ_PM => { 'Test::More' => 0, 'Exporter' => '5.57' }, 7 | ABSTRACT_FROM => 'lib/XSFun.pm', 8 | AUTHOR => 'You', 9 | LIBS => [''], 10 | DEFINE => '', 11 | INC => '-I.', 12 | OBJECT => '$(O_FILES)', 13 | ); 14 | 15 | -------------------------------------------------------------------------------- /chapter_01/XSFun/XSFun.xs: -------------------------------------------------------------------------------- 1 | #define PERL_NO_GET_CONTEXT 2 | #include "EXTERN.h" 3 | #include "perl.h" 4 | #include "XSUB.h" 5 | #include "ppport.h" 6 | 7 | /* C functions */ 8 | 9 | MODULE = XSFun PACKAGE = XSFun 10 | 11 | # XS code 12 | 13 | double 14 | add_numbers(double a, double b) 15 | CODE: 16 | RETVAL = a + b; 17 | OUTPUT: 18 | RETVAL 19 | 20 | SV * 21 | add_numbers_perl(SV *a, SV *b) 22 | CODE: 23 | { 24 | const double sum = SvNV(a) + SvNV(b); 25 | RETVAL = newSVnv(sum); 26 | } 27 | OUTPUT: RETVAL 28 | 29 | -------------------------------------------------------------------------------- /chapter_01/XSFun/lib/XSFun.pm: -------------------------------------------------------------------------------- 1 | package XSFun; 2 | 3 | use strict; 4 | use warnings; 5 | use XSLoader; 6 | 7 | use Exporter 5.57 'import'; 8 | 9 | our $VERSION = '0.001'; 10 | our %EXPORT_TAGS = ( 'all' => [qw] ); 11 | our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); 12 | 13 | XSLoader::load('XSFun', $VERSION); 14 | 15 | 1; 16 | 17 | =head1 NAME 18 | 19 | XSFun - Learning XS the fun way 20 | -------------------------------------------------------------------------------- /chapter_01/XSFun/t/add_numbers.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings; 4 | 5 | use Test::More tests => 9; 6 | 7 | use_ok( 'XSFun', ':all' ); 8 | 9 | # testing integers 10 | is( add_numbers( 5, 3 ), 8, '5 + 3 = 8' ); 11 | is( add_numbers( 31, 1 ), 32, '31 + 1 = 32' ); 12 | 13 | is( add_numbers_perl( 5, 3 ), 8, '5 + 3 = 8' ); 14 | is( add_numbers_perl( 31, 1 ), 32, '31 + 1 = 32' ); 15 | 16 | # testing fractions 17 | is( add_numbers( 3.1, 4.2 ), 7.3, '3.1 + 4.2 = 7.3' ); 18 | is( add_numbers( 3.2, 4.3 ), 7.5, '3.2 + 4.3 = 7.5' ); 19 | 20 | is( add_numbers_perl( 3.1, 4.2 ), 7.3, '3.1 + 4.2 = 7.3' ); 21 | is( add_numbers_perl( 3.2, 4.3 ), 7.5, '3.2 + 4.3 = 7.5' ); 22 | 23 | -------------------------------------------------------------------------------- /chapter_01/chapter_01.pod: -------------------------------------------------------------------------------- 1 | =head1 Basic XS 2 | 3 | XS allows us to embed C code directly in the XS file. Hence, it doesn't need 4 | to be in a completely separate library. We can therefore write functions in 5 | C that will help us speed up our code. If we have a function that needs 6 | intensive calculation, moving that to C will give us much more speed. 7 | 8 | In this chapter we show how to create a basic C function in XS, how the same 9 | functionality can be achieved using Perl types, discuss simple interactive 10 | debugging strategies, and add automated tests of our newly created 11 | functions. 12 | 13 | =head2 Basic functions 14 | 15 | Let's add a function to our XS code. Create a new directory for this 16 | project and copy across the skeleton C, C and 17 | C files from our initial template directory. 18 | 19 | Open the C file and copy the following after the I 20 | comment: 21 | 22 | double 23 | add_numbers(double a, double b) 24 | CODE: 25 | RETVAL = a + b; 26 | OUTPUT: 27 | RETVAL 28 | 29 | We define a function called C. It takes two numbers of type 30 | I and as you can see by the definition, it also returns a I 31 | type. 32 | 33 | We have a I section which sets the return value (I) to the sum 34 | of I and I. We also have an I section that indicates the output 35 | is the return value (I). 36 | 37 | =head2 A touch of Perl API 38 | 39 | Instead of working with pure C types, we can use Perl types. We can write a 40 | function that receives pointers to two SVs (Scalar Values) and returns an SV 41 | pointer to the result. We will create a new SV to represent the value and 42 | return a pointer to that. 43 | 44 | SV * 45 | add_numbers_perl(SV *a, SV *b) 46 | CODE: 47 | { 48 | const double sum = SvNV(a) + SvNV(b); 49 | RETVAL = newSVnv(sum); 50 | } 51 | OUTPUT: RETVAL 52 | 53 | =head2 Building the project 54 | 55 | We're now in a position to build the project and compile the library. As 56 | with many Perl modules one creates the C by running 57 | 58 | perl Makefile.PL 59 | 60 | after which we merely need to run 61 | 62 | make 63 | 64 | and our library is available within the C directory. 65 | 66 | Note that if you're using Strawberry Perl on Windows, use C instead 67 | of C. 68 | 69 | =head2 Playing with our shiny new library 70 | 71 | Let's have a quick play with the library. We can use the Perl debugger as a 72 | kind of 73 | L 74 | by using the C<-de0> options to C, then we can use the library and try 75 | running the functions we've just defined. Type the following into the 76 | console: 77 | 78 | perl -de0 -Iblib/lib -Iblib/arch 79 | 80 | The C<-I> options tell C where to look for the library files we just 81 | created with C. You will now see something like this: 82 | 83 | Loading DB routines from perl5db.pl version 1.39_11 84 | Editor support available. 85 | 86 | Enter h or 'h h' for help, or 'man perldebug' for more help. 87 | 88 | main::(-e:1): 0 89 | DB<1> 90 | 91 | The C<< DB >> is the prompt of our REPL; the number in the angle brackets 92 | will increment as we enter commands into the debugger. Let's use the 93 | C module so that we can run our C and 94 | C functions. 95 | 96 | Type 97 | 98 | use XSFun 99 | 100 | at the command prompt. You should simply see the prompt returned, which 101 | means that the library has been loaded successfully. If an error occurred 102 | you might need to check the C<-I> options on the command line and/or rebuild 103 | the library; you can exit the debugger by entering C at the prompt. 104 | 105 | Assuming all went well, we can see if we can add numbers together. Since 106 | we've not yet exported the functions, we have to specify the functions along 107 | with the package name. Try running the following commands at the prompt: 108 | 109 | print XSFun::add_numbers(1, 2) 110 | print XSFun::add_numbers(1.4, 3.2) 111 | 112 | As one would hope, we see the output C<3> and C<4.6> respectively. Hooray! 113 | The C function seems to work as expected. Running similar 114 | commands on the C function also shows that this function 115 | behaves as we would wish. Quit the debugger by typing C at the prompt. 116 | 117 | =head2 Exporting our functions 118 | 119 | It'd be nicer to simply have to call C or C 120 | without having to prefix them with the package name. To do this we need to 121 | export the functions. 122 | 123 | Open F and fix the C<%EXPORT_TAGS> variable to include the 124 | functions we wish to export: 125 | 126 | our %EXPORT_TAGS = ( 'all' => [qw] ); 127 | 128 | If we now run C, reload the debugger and load the library with 129 | 130 | use XSFun qw(:all) 131 | 132 | then we will find that we can call the functions directly: 133 | 134 | DB<2> print add_numbers(2, 3) 135 | 5 136 | DB<3> q 137 | 138 | =head2 Testing 139 | 140 | Checking that things work by using the Perl debugger as a REPL is nice to 141 | quickly show that something worked, however it'd be heaps better if we could 142 | automate the process. So, let's write a small test script that shows off 143 | our spectacular code. Create a directory F and inside it create the 144 | following file F: 145 | 146 | #!perl 147 | use strict; 148 | use warnings; 149 | 150 | use Test::More tests => 9; 151 | 152 | use_ok( 'XSFun', ':all' ); 153 | 154 | # testing integers 155 | is( add_numbers( 5, 3 ), 8, '5 + 3 = 8' ); 156 | is( add_numbers( 31, 1 ), 32, '31 + 1 = 32' ); 157 | 158 | is( add_numbers_perl( 5, 3 ), 8, '5 + 3 = 8' ); 159 | is( add_numbers_perl( 31, 1 ), 32, '31 + 1 = 32' ); 160 | 161 | # testing fractions 162 | is( add_numbers( 3.1, 4.2 ), 7.3, '3.1 + 4.2 = 7.3' ); 163 | is( add_numbers( 3.2, 4.3 ), 7.5, '3.2 + 4.3 = 7.5' ); 164 | 165 | is( add_numbers_perl( 3.1, 4.2 ), 7.3, '3.1 + 4.2 = 7.3' ); 166 | is( add_numbers_perl( 3.2, 4.3 ), 7.5, '3.2 + 4.3 = 7.5' ); 167 | 168 | Now let's run the tests. Note that it's important to rebuild the F so C 169 | knows about the newly added tests: 170 | 171 | perl Makefile.PL && make && make test 172 | 173 | You should see output similar to this: 174 | 175 | t/add_numbers.t .. ok 176 | All tests successful. 177 | Files=1, Tests=9, 0 wallclock secs ( 0.02 usr 0.01 sys + 0.02 cusr 0.00 178 | csys = 0.05 CPU) 179 | Result: PASS 180 | 181 | =head3 Why use C instead of C? 182 | 183 | Usually we would use C's C to test numerical values, but 184 | in this case we picked C. The reason is that the result we get back from 185 | our function has a different absolute value from the one we check for in the 186 | function, because of how Perl stores floating point values. 187 | 188 | We can use C to show the differences: 189 | 190 | $ perl -e 'printf "%.40f\n", $_ for 3.1+4.2, 7.3' 191 | 7.3000000000000007105427357601001858711243 192 | 7.2999999999999998223643160599749535322189 193 | 194 | =head2 Cleaning up 195 | 196 | Note that you can run the following command to clean up your directory: 197 | 198 | make clean 199 | 200 | This will remove almost all files that have been automatically generated. 201 | To be more thorough, you can use 202 | 203 | make realclean 204 | -------------------------------------------------------------------------------- /chapter_02/XSFun/Makefile.PL: -------------------------------------------------------------------------------- 1 | use 5.008005; 2 | use ExtUtils::MakeMaker; 3 | WriteMakefile( 4 | NAME => 'XSFun', 5 | VERSION_FROM => 'lib/XSFun.pm', 6 | PREREQ_PM => { 'Test::More' => 0, Exporter => '5.57' }, 7 | ABSTRACT_FROM => 'lib/XSFun.pm', 8 | AUTHOR => 'You', 9 | LIBS => ['-lchromaprint'], 10 | DEFINE => '', 11 | INC => '-I.', 12 | OBJECT => '$(O_FILES)', 13 | ); 14 | 15 | -------------------------------------------------------------------------------- /chapter_02/XSFun/XSFun.xs: -------------------------------------------------------------------------------- 1 | #define PERL_NO_GET_CONTEXT 2 | #include "EXTERN.h" 3 | #include "perl.h" 4 | #include "XSUB.h" 5 | #include "ppport.h" 6 | 7 | #include 8 | 9 | /* C functions */ 10 | 11 | MODULE = XSFun PACKAGE = XSFun 12 | 13 | # XS code 14 | 15 | const char * 16 | get_version() 17 | CODE: 18 | RETVAL = chromaprint_get_version(); 19 | OUTPUT: RETVAL 20 | 21 | -------------------------------------------------------------------------------- /chapter_02/XSFun/lib/XSFun.pm: -------------------------------------------------------------------------------- 1 | package XSFun; 2 | 3 | use strict; 4 | use warnings; 5 | use Exporter 5.57 'import'; 6 | use XSLoader; 7 | 8 | our $VERSION = '0.001'; 9 | our %EXPORT_TAGS = ( 'all' => [qw] ); 10 | our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); 11 | 12 | XSLoader::load('XSFun', $VERSION); 13 | 14 | 1; 15 | 16 | =head1 NAME 17 | 18 | XSFun - Learning XS the fun way 19 | -------------------------------------------------------------------------------- /chapter_02/XSFun/t/version.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings; 4 | 5 | use Test::More tests => 2; 6 | 7 | use_ok( 'XSFun', ':all' ); 8 | 9 | is( get_version(), '1.2.0', 'chromaprint version is 1.2.0' ); 10 | 11 | -------------------------------------------------------------------------------- /chapter_02/chapter_02.pod: -------------------------------------------------------------------------------- 1 | =head1 Basic external library functions 2 | 3 | =head2 Compiling against a library 4 | 5 | While it's good to be able to speed-up portions of our code using XS, another 6 | major use of XS is to create bindings to C and C++ libraries. 7 | 8 | We will play with a relatively simple library called I, an 9 | audio fingerprinting library. You will need to install the development files 10 | for it, the headers and sources. 11 | 12 | If you're on GNU/Linux you probably have the library in your distribution 13 | resources. If you're on Windows or want to compile it manually, you can find 14 | the sources at L. 15 | 16 | Open the F and edit the C key to add C: 17 | 18 | LIBS => ['-lchromaprint'], 19 | 20 | This will compile our code with I. 21 | 22 | =head2 The smallest function 23 | 24 | Let's start with a simple function that fetches the library version. Add the 25 | following XS code to C: 26 | 27 | #include 28 | 29 | const char * 30 | get_version() 31 | CODE: 32 | RETVAL = chromaprint_get_version(); 33 | OUTPUT: RETVAL 34 | 35 | Let's add a test for it. Create a file F with the following: 36 | 37 | #!perl 38 | 39 | use strict; 40 | use warnings; 41 | 42 | use Test::More tests => 2; 43 | 44 | use_ok( 'XSFun', ':all' ); 45 | 46 | is( get_version(), '1.2.0', 'chromaprint version is 1.2.0' ); 47 | 48 | Remember to export the function in C: 49 | 50 | our %EXPORT_TAGS = ( 'all' => [qw] ); 51 | 52 | Now try to compile and run the code: 53 | 54 | perl Makefile.PL && make && make test 55 | 56 | (if you're using Strawberry Perl on Windows, use C instead of 57 | C). 58 | -------------------------------------------------------------------------------- /chapter_03/Audio-Chromaprint/Chromaprint.xs: -------------------------------------------------------------------------------- 1 | #define PERL_NO_GET_CONTEXT 2 | #include "EXTERN.h" 3 | #include "perl.h" 4 | #include "XSUB.h" 5 | #include "ppport.h" 6 | 7 | #include 8 | 9 | /* C functions */ 10 | 11 | MODULE = Audio::Chromaprint PACKAGE = Audio::Chromaprint 12 | 13 | # XS code 14 | 15 | PROTOTYPES: ENABLED 16 | 17 | SV * 18 | new( const char *class ) 19 | CODE: 20 | /* Create a hash */ 21 | HV* hash = newHV(); 22 | 23 | /* Create a reference to the hash */ 24 | SV* const self = newRV_noinc( (SV *)hash ); 25 | 26 | /* bless into the proper package */ 27 | RETVAL = sv_bless( self, gv_stashpv( class, 0 ) ); 28 | OUTPUT: RETVAL 29 | 30 | const char * 31 | version(SV *self) 32 | CODE: 33 | RETVAL = chromaprint_get_version(); 34 | OUTPUT: RETVAL 35 | 36 | -------------------------------------------------------------------------------- /chapter_03/Audio-Chromaprint/MANIFEST: -------------------------------------------------------------------------------- 1 | Chromaprint.xs 2 | lib/Audio/Chromaprint.pm 3 | Makefile.PL 4 | MANIFEST This list of files 5 | ppport.h 6 | t/leak.t 7 | t/version.t 8 | -------------------------------------------------------------------------------- /chapter_03/Audio-Chromaprint/Makefile.PL: -------------------------------------------------------------------------------- 1 | use 5.008005; 2 | use ExtUtils::MakeMaker; 3 | WriteMakefile( 4 | NAME => 'Audio::Chromaprint', 5 | VERSION_FROM => 'lib/Audio/Chromaprint.pm', 6 | PREREQ_PM => { 'Test::More' => 0 }, 7 | ABSTRACT_FROM => 'lib/Audio/Chromaprint.pm', 8 | AUTHOR => 'You', 9 | LIBS => ['-lchromaprint'], 10 | DEFINE => '', 11 | INC => '-I.', 12 | OBJECT => '$(O_FILES)', 13 | ); 14 | 15 | -------------------------------------------------------------------------------- /chapter_03/Audio-Chromaprint/lib/Audio/Chromaprint.pm: -------------------------------------------------------------------------------- 1 | package Audio::Chromaprint; 2 | 3 | use strict; 4 | use warnings; 5 | use XSLoader; 6 | 7 | our $VERSION = '0.001'; 8 | 9 | XSLoader::load( 'Audio::Chromaprint', $VERSION ); 10 | 11 | 1; 12 | 13 | __END__ 14 | 15 | =head1 NAME 16 | 17 | Audio::Chromaprint - Interface to the Chromaprint library 18 | 19 | -------------------------------------------------------------------------------- /chapter_03/Audio-Chromaprint/t/leak.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 2; 6 | 7 | use_ok( 'Audio::Chromaprint' ); 8 | 9 | my $called = 0; 10 | package Audio::Chromaprint { 11 | sub DESTROY { 12 | $called++; 13 | } 14 | } 15 | 16 | { 17 | my $cp = Audio::Chromaprint->new; 18 | } 19 | 20 | cmp_ok( $called, '==', 1, 'Destruction successful' ); 21 | -------------------------------------------------------------------------------- /chapter_03/Audio-Chromaprint/t/version.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings; 4 | 5 | use Test::More tests => 4; 6 | 7 | use_ok( 'Audio::Chromaprint' ); 8 | 9 | my $cp = Audio::Chromaprint->new(); 10 | isa_ok( $cp, 'Audio::Chromaprint' ); 11 | can_ok( $cp, 'version' ); 12 | 13 | is( $cp->version, '1.2.0', 'chromaprint version is 1.2.0' ); 14 | 15 | -------------------------------------------------------------------------------- /chapter_03/chapter_03.pod: -------------------------------------------------------------------------------- 1 | =head1 Enter object oriented 2 | 3 | =head2 Introduction 4 | 5 | While a functional interface for the C function was useful, the 6 | B library, as many libraries do, has context. This means we 7 | would be better off using an object oriented interface. 8 | 9 | We will convert the C function into a method and then create a 10 | C method to generate a new Ced hash reference. The second step 11 | can easily be done with Perl itself (which we will also demonstrate), but 12 | we're trying to learn us some XS, aren't we? 13 | 14 | =head2 Preparation 15 | 16 | First of all, we create a new skeleton which has the same structure as the 17 | old one but with new file names and using a proper namespace. 18 | 19 | =head3 Makefile.PL 20 | 21 | Create a new F file with the following content: 22 | 23 | use 5.008005; 24 | use ExtUtils::MakeMaker; 25 | WriteMakefile( 26 | NAME => 'Audio::Chromaprint', 27 | VERSION_FROM => 'lib/Audio/Chromaprint.pm', 28 | PREREQ_PM => { 'Test::More' => 0 }, 29 | ABSTRACT_FROM => 'lib/Audio/Chromaprint.pm', 30 | AUTHOR => 'You', 31 | LIBS => ['-lchromaprint'], 32 | DEFINE => '', 33 | INC => '-I.', 34 | OBJECT => '$(O_FILES)', 35 | ); 36 | 37 | =head3 ppport.h 38 | 39 | You can generate the F file using the following command: 40 | 41 | perl -MDevel::PPPort -E'Devel::PPPort::WriteFile' 42 | 43 | Or on Windows cmd.exe with Strawberry Perl: 44 | 45 | perl -MDevel::PPPort -E"Devel::PPPort::WriteFile" 46 | 47 | =head3 Chromaprint.pm 48 | 49 | Create a directory structure F and inside the file 50 | F: 51 | 52 | package Audio::Chromaprint; 53 | 54 | use strict; 55 | use warnings; 56 | use XSLoader; 57 | 58 | our $VERSION = '0.001'; 59 | 60 | XSLoader::load( 'Audio::Chromaprint', $VERSION ); 61 | 62 | 1; 63 | 64 | __END__ 65 | 66 | =head1 NAME 67 | 68 | Audio::Chromaprint - Interface to the Chromaprint library 69 | 70 | You'll notice we removed the exporting, which is unnecessary for object 71 | oriented interfaces, and added a B section in the documentation at the 72 | bottom to provide an abstract to F. 73 | 74 | =head3 MANIFEST 75 | 76 | The F file can be easily created with the command: 77 | 78 | # Perl on GNU/Linux, BSD, Solaris: 79 | perl Makefile.PL && make manifest && make distclean 80 | 81 | (if you're using Strawberry Perl on Windows, use C instead of C) 82 | 83 | =head3 Chromaprint.xs 84 | 85 | Now we create the F file which is associated with the 86 | correct package loaded by our F file: 87 | 88 | #define PERL_NO_GET_CONTEXT 89 | #include "EXTERN.h" 90 | #include "perl.h" 91 | #include "XSUB.h" 92 | #include "ppport.h" 93 | 94 | #include 95 | 96 | /* Custom C functions can go here */ 97 | 98 | MODULE = Audio::Chromaprint PACKAGE = Audio::Chromaprint 99 | 100 | # XS code goes here 101 | 102 | PROTOTYPES: ENABLED 103 | 104 | We define the module and package as C. 105 | 106 | You will notice we also added a definition for B. This isn't 107 | necessary, and the default value is C anyway, but it will remove a 108 | warning the XS layer adds, so we add it explicitly. 109 | 110 | =head2 Convert to method: version 111 | 112 | Our previous C function had one major problem: it assumed that 113 | we did not have any parameters. 114 | 115 | If you are unfamiliar with methods in Perl, it's important to know that when 116 | you call a method, it will send the object as the first parameter. Assuming we 117 | were using an object oriented interface: 118 | 119 | $object->my_method(); 120 | 121 | The method C is not without parameters at all. It receives the 122 | object as the first parameter: 123 | 124 | sub my_method { 125 | my $self = shift; 126 | ... 127 | } 128 | 129 | Thus, as soon as we try to use our C as a method, because it 130 | assumes there are no parameters, it will fail. The XS layer will generate a 131 | check for any possible arguments and will croak mentioning the "proper" way 132 | of calling it (assuming it shouldn't receive parameters at all). 133 | 134 | In order to fix this, the only thing we need is to include a parameter in the 135 | name definition for the function, which will now be a method: 136 | 137 | const char * 138 | version(SV *self) 139 | CODE: 140 | RETVAL = chromaprint_get_version(); 141 | OUTPUT: RETVAL 142 | 143 | This way the XS layer will generate a check that the function is called as 144 | a method (providing at least one parameter, an SV), instead of being called 145 | as a function with no parameters. 146 | 147 | You will notice we also took the liberty to change the method name to 148 | C. 149 | 150 | =head2 A C method as in Perl 151 | 152 | The above C method will be a Perl sub that B. 153 | That means in Perl, it can be called in two ways: 154 | 155 | $obj->version() 156 | version($obj) 157 | 158 | So the XSUB behaves just the same as any other sub would do in 159 | Perl. The only difference is that if the method were implemented in Perl, 160 | it wouldn't use its object parameter at all, so 161 | 162 | version() # look Ma, no arguments! 163 | 164 | would also be legal. However, the XSUB will C on that. In this case 165 | that is probably a good thing. But if you wanted it to behave even more 166 | like an actual Perl function that could be called without arguments, 167 | the XS code would look like this instead: 168 | 169 | const char * 170 | version(...) 171 | CODE: 172 | RETVAL = chromaprint_get_version(); 173 | OUTPUT: RETVAL 174 | 175 | See what we did there? We dropped the explicit parameter C and 176 | replaced it with C<...>, which basically says "any number of parameters 177 | is okay". Later on we will see how to actually use parameters passed to 178 | such a variadic XSUB. 179 | 180 | =head2 Add method: new 181 | 182 | In order to call C as a method, we need a blessed hash reference. We 183 | can easily create one with the following code inside F: 184 | 185 | sub new { bless {}, shift } 186 | 187 | In a single line, this creates a subroutine called C which blesses an 188 | empty hash reference into the class name that is sent as a parameter. 189 | 190 | However, as we're trying to practice XS, let us do it in XS: 191 | 192 | SV * 193 | new( const char *class ) 194 | CODE: 195 | /* Create a hash */ 196 | HV* hash = newHV(); 197 | 198 | /* Create a reference to the hash */ 199 | SV *const self = newRV_noinc( (SV *)hash ); 200 | 201 | /* bless into the proper package */ 202 | RETVAL = sv_bless( self, gv_stashpv( class, 0 ) ); 203 | OUTPUT: RETVAL 204 | 205 | C creates a new hash value. It returns a pointer to a hash value 206 | structure (C). 207 | 208 | Then we want to create a reference to it (C - Reference Value structure). 209 | C and C create a reference from an SV. It expects an 210 | SV, so we cast our HV as one. We return the data back into a new SV. 211 | 212 | The last step is to bless the SV. We use C to fetch a pointer to 213 | the stash of a specified package. We send it the class name as the package, 214 | and C<0> as the indication of no additional flags to the function. 215 | C is called with the hash reference we created with C 216 | and the pointer from C. 217 | 218 | In case you're wondering where the heck that weird C thing is coming 219 | from: It's a C variable that is automatically declared for us and which has the 220 | same type as the return value of the XSUB. We can set it in our XS code and 221 | then tell the XS compiler using C that yes, really, its 222 | content is to be returned to Perl. 223 | 224 | =head2 Testing 225 | 226 | Let's write a test for our code. We can write the following as F: 227 | 228 | #!perl 229 | use strict; 230 | use warnings; 231 | 232 | use Test::More tests => 3; 233 | use Audio::Chromaprint; 234 | 235 | my $cp = Audio::Chromaprint->new(); 236 | isa_ok( $cp, 'Audio::Chromaprint' ); 237 | can_ok( $cp, 'version' ); 238 | 239 | is( $cp->version, '1.2.0', 'chromaprint version is 1.2.0' ); 240 | 241 | Try it out: 242 | 243 | perl Makefile.PL && make && make test 244 | 245 | (if you're using Strawberry Perl on Windows, use C instead of C) 246 | 247 | =head2 To increment or not to increment 248 | 249 | You might notice both C and C were mentioned, but only 250 | C was used. Why is that? 251 | 252 | Perl uses a reference counting memory management system. When a new value 253 | is created, its reference count is set to 1. No matter whether it came 254 | into life as a variable in Perl code, as a temporary deep inside 255 | the bowels of the runtime, or explicitly using C or its siblings 256 | in your XS code. 257 | 258 | Perl keeps a count of "live" values (technically, the most generic form of a 259 | Perl value is an C) using the count of things that refer to it. 260 | 261 | When they go out of scope, or get explicitly Ced, their reference count 262 | is decremented. When it reaches zero, perl (the interpreter) knows 263 | it can free that value and will generally do so immediately. 264 | 265 | When we create an C, it has a single reference count. Our code effectively 266 | "owns" that value. When we create an C that points at the C, 267 | the C should now have its own reference count to the C. 268 | 269 | We can now use C to create the C. That Irements the hash's 270 | reference count to 2, and both the C and our code own one reference to it. 271 | 272 | C creates an C without increasing the reference count. 273 | Generally, this means that the C is taking ownership of one of the 274 | existing references. 275 | 276 | Why is this important? We don't plan to hold on to that C in our code. 277 | The C will fully own it and we will return the reference, the C from 278 | the XSUB. If that C is freed, it will give up its reference (count) to 279 | the C and perl will free the C correctly. 280 | 281 | To understand this better write the following test in F: 282 | 283 | #!perl 284 | use strict; 285 | use warnings; 286 | use Test::More tests => 1; 287 | use Audio::Chromaprint; 288 | 289 | my $called = 0; 290 | package Audio::Chromaprint { 291 | sub DESTROY { $called++ } 292 | } 293 | 294 | { my $cp = Audio::Chromaprint->new } 295 | cmp_ok( $called, '==', 1, 'Destruction successful' ); 296 | 297 | In this test we add a C method to the C package 298 | namespace, which will get called when the object is entirely destroyed. We use 299 | that method to increment a counter. Then we create an object in an internal 300 | scope. Once out of the scope, we check that the counter was called once and 301 | only once. 302 | 303 | If you run C, it will succeed. Try changing in the XS code the 304 | C to C, rebuild and rerun the test. It will fail 305 | because there's a stray reference to the objects' Cs and they will 306 | never be freed (and the destructor will never be called). 307 | 308 | -------------------------------------------------------------------------------- /chapter_04/Audio-Chromaprint/Chromaprint.xs: -------------------------------------------------------------------------------- 1 | #define PERL_NO_GET_CONTEXT 2 | #include "EXTERN.h" 3 | #include "perl.h" 4 | #include "XSUB.h" 5 | #include "ppport.h" 6 | 7 | #include 8 | 9 | MODULE = Audio::Chromaprint PACKAGE = Audio::Chromaprint 10 | 11 | PROTOTYPES: ENABLED 12 | 13 | SV * 14 | new( const char *class, ... ) 15 | CODE: 16 | if ( ( items - 1 ) % 2 ) 17 | croak("Expecting key/value pairs as input to constructor"); 18 | 19 | HV *hash = newHV(); 20 | 21 | hv_store( 22 | hash, 23 | "algorithm", 24 | strlen("algorithm"), 25 | newSVpv( "test2", strlen("test2") ), 26 | 0 27 | ); 28 | 29 | int i; 30 | for ( i = 1; i < items; i += 2 ) { 31 | SV *key = ST(i); 32 | SV *value = newSVsv( ST( i + 1 ) ); 33 | 34 | hv_store_ent( hash, key, value, 0 ); 35 | } 36 | 37 | SV* const self = newRV_noinc( (SV *)hash ); 38 | 39 | RETVAL = sv_bless( self, gv_stashpv( class, 0 ) ); 40 | OUTPUT: RETVAL 41 | 42 | const char * 43 | version(SV *self) 44 | CODE: 45 | RETVAL = chromaprint_get_version(); 46 | OUTPUT: RETVAL 47 | 48 | -------------------------------------------------------------------------------- /chapter_04/Audio-Chromaprint/MANIFEST: -------------------------------------------------------------------------------- 1 | Chromaprint.xs 2 | lib/Audio/Chromaprint.pm 3 | Makefile.PL 4 | MANIFEST This list of files 5 | ppport.h 6 | t/leak.t 7 | t/version.t 8 | -------------------------------------------------------------------------------- /chapter_04/Audio-Chromaprint/Makefile.PL: -------------------------------------------------------------------------------- 1 | use 5.008005; 2 | use ExtUtils::MakeMaker; 3 | WriteMakefile( 4 | NAME => 'Audio::Chromaprint', 5 | VERSION_FROM => 'lib/Audio/Chromaprint.pm', 6 | PREREQ_PM => { 'Test::More' => 0 }, 7 | ABSTRACT_FROM => 'lib/Audio/Chromaprint.pm', 8 | AUTHOR => 'You', 9 | LIBS => ['-lchromaprint'], 10 | DEFINE => '', 11 | INC => '-I.', 12 | OBJECT => '$(O_FILES)', 13 | ); 14 | 15 | -------------------------------------------------------------------------------- /chapter_04/Audio-Chromaprint/lib/Audio/Chromaprint.pm: -------------------------------------------------------------------------------- 1 | package Audio::Chromaprint; 2 | 3 | use strict; 4 | use warnings; 5 | use XSLoader; 6 | 7 | our $VERSION = '0.001'; 8 | 9 | XSLoader::load( 'Audio::Chromaprint', $VERSION ); 10 | 11 | 1; 12 | 13 | __END__ 14 | 15 | =head1 NAME 16 | 17 | Audio::Chromaprint - Interface to the Chromaprint library 18 | 19 | -------------------------------------------------------------------------------- /chapter_04/Audio-Chromaprint/t/leak.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 2; 6 | 7 | use_ok( 'Audio::Chromaprint' ); 8 | 9 | my $called = 0; 10 | package Audio::Chromaprint { 11 | sub DESTROY { 12 | $called++; 13 | } 14 | } 15 | 16 | { 17 | my $cp = Audio::Chromaprint->new; 18 | } 19 | 20 | cmp_ok( $called, '==', 1, 'Destruction successful' ); 21 | -------------------------------------------------------------------------------- /chapter_04/Audio-Chromaprint/t/new.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 11; 6 | use Test::Fatal; 7 | 8 | use_ok( 'Audio::Chromaprint' ); 9 | 10 | { 11 | like( 12 | exception { Audio::Chromaprint->new('SingleInput') }, 13 | qr{^Expecting key/value pairs as input to constructor}, 14 | 'Incorrect input for single item (instead of pairs)', 15 | ); 16 | 17 | like( 18 | exception { Audio::Chromaprint->new( 1, 2, 3 ) }, 19 | qr{^Expecting key/value pairs as input to constructor}, 20 | 'Incorrect input for odd items (instead of pairs)', 21 | ); 22 | 23 | is( 24 | exception { Audio::Chromaprint->new() }, 25 | undef, 26 | 'Successful at calling a constructor without arguments', 27 | ); 28 | 29 | is( 30 | exception { Audio::Chromaprint->new( key => 'value' ) }, 31 | undef, 32 | 'Successful at calling a constructor with even items', 33 | ); 34 | } 35 | 36 | { 37 | my $cp = Audio::Chromaprint->new(); 38 | 39 | isa_ok( $cp, 'Audio::Chromaprint' ); 40 | is( 41 | $cp->{'algorithm'}, 42 | 'test2', 43 | 'Constructor set correct default algorithm', 44 | ); 45 | } 46 | 47 | { 48 | my $cp = Audio::Chromaprint->new( 49 | algorithm => 'test3' 50 | ); 51 | 52 | isa_ok( $cp, 'Audio::Chromaprint' ); 53 | is( 54 | $cp->{'algorithm'}, 55 | 'test3', 56 | 'Constructor set correct algorithm from argument', 57 | ); 58 | 59 | is( 60 | exception { $cp->{'algorithm'} = 'test1' }, 61 | undef, 62 | 'We can change the algorithm key directly', 63 | ); 64 | 65 | is( 66 | $cp->{'algorithm'}, 67 | 'test1', 68 | 'It was changed correctly', 69 | ); 70 | } 71 | 72 | -------------------------------------------------------------------------------- /chapter_04/Audio-Chromaprint/t/version.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings; 4 | 5 | use Test::More tests => 4; 6 | 7 | use_ok( 'Audio::Chromaprint' ); 8 | 9 | my $cp = Audio::Chromaprint->new(); 10 | isa_ok( $cp, 'Audio::Chromaprint' ); 11 | can_ok( $cp, 'version' ); 12 | 13 | is( $cp->version, '1.2.0', 'chromaprint version is 1.2.0' ); 14 | 15 | -------------------------------------------------------------------------------- /chapter_04/chapter_04.pod: -------------------------------------------------------------------------------- 1 | =head1 Better construction 2 | 3 | =head2 What's in a constructor? 4 | 5 | Most constructors don't just create objects. Blessing a reference is cool, 6 | but usually we need more than that. If we want to improve our constructor, 7 | we would need to make it update the attributes we keep in the hash. 8 | 9 | Of course, one more important feature is being able to provide attribute 10 | subroutines. They will allow us to fetch the attribute from the hash and 11 | to set a new value - what's called I. 12 | 13 | This chapter will start with creating a default value for an attribute 14 | (or, rather, a key in our C<$self> hash), and will then focus on improving 15 | the accessor by letting it set the attribute value by user arguments. 16 | 17 | Since this covers quite a lot of ground, we will leave the accessors to 18 | a future chapter. 19 | 20 | Let's dig in! 21 | 22 | =head2 First, the tests 23 | 24 | To make sure we don't screw up, we will write some tests. They will cover 25 | checking our constructor. 26 | 27 | Reading the documentation for B, we see that there's an attribute 28 | defining the algorithm to be used. It has a default, B (or the actual 29 | constant name, B). Let's test that we're setting 30 | it properly. 31 | 32 | =head3 new.t 33 | 34 | Beginning with F, we can write the following simple test: 35 | 36 | #!perl 37 | 38 | use strict; 39 | use warnings; 40 | use Test::More tests => 2; 41 | use Audio::Chromaprint; 42 | 43 | my $cp = Audio::Chromaprint->new(); 44 | 45 | isa_ok( $cp, 'Audio::Chromaprint' ); 46 | is( 47 | $cp->{'algorithm'}, 48 | 'test2', 49 | 'Constructor set correct default algorithm', 50 | ); 51 | 52 | =head3 Running 53 | 54 | When running the test, we can ask the testing harness to only run the new 55 | test file we wrote and nothing else. 56 | 57 | Assuming we have the default template with nothing in it, running the test 58 | will work like so: 59 | 60 | $ perl Makefile.PL 61 | $ make && make test TEST_VERBOSE=1 TEST_FILES="t/new.t" 62 | 63 | After we have run the F, we have a F file, and it 64 | allows us to repeat the C line as many times as we want. 65 | 66 | Here is the output: 67 | 68 | 1..2 69 | ok 1 - The object isa Audio::Chromaprint 70 | not ok 2 - Constructor set correct default algorithm 71 | 72 | # Failed test 'Constructor set correct default algorithm' 73 | # at t/new.t line 13. 74 | # got: undef 75 | # expected: 'test2' 76 | # Looks like you failed 1 test of 2. 77 | Dubious, test returned 1 (wstat 256, 0x100) 78 | Failed 1/2 subtests 79 | 80 | As you can see, we failed the second test because we did not provide a 81 | value. Let's fix it. 82 | 83 | =head2 Adding a default value 84 | 85 | To add a default value, we would need to add data to the hash. This means 86 | creating a new value (B) and setting it in a key in the hash 87 | we created. 88 | 89 | We can use C (which can be found it L) in order to store 90 | a new value in the hash we created in the previous chapter. Let's add it: 91 | 92 | SV * 93 | new( const char *class, ... ) 94 | CODE: 95 | HV *hash = newHV(); 96 | 97 | /* using sv_store we need to provide the following: 98 | * hash in which to store 99 | * the key 100 | * key length 101 | * SV with the value 102 | * pre-calculated hash or 0 103 | */ 104 | 105 | hv_store( 106 | hash, /* created before */ 107 | "algorithm", /* key */ 108 | strlen("algorithm"), /* length */ 109 | newSVpv( "test2", strlen("test2") ), /* new SV with PV */ 110 | 0 /* let Perl calculate */ 111 | ); 112 | 113 | SV* const self = newRV_noinc( (SV *)hash ); 114 | 115 | RETVAL = sv_bless( self, gv_stashpv( class, 0 ) ); 116 | OUTPUT: RETVAL 117 | 118 | =head2 Re-run tests 119 | 120 | $ make && make test TEST_VERBOSE=1 TEST_FILES="t/new.t" 121 | 122 | 1..2 123 | ok 1 - The object isa Audio::Chromaprint 124 | ok 2 - Constructor set correct default algorithm 125 | ok 126 | All tests successful. 127 | 128 | It works! 129 | 130 | =head2 Smarter constructor 131 | 132 | Now that we have a default, we would like the user to be able to set it 133 | to anything they wish. 134 | 135 | =head3 Improving our test 136 | 137 | Let's write a test to reflect what we want to happen. We'll start with 138 | what we have and add another chunk that changes the value using the 139 | constructor. We put each chunk in its own scope so we don't override the 140 | variables. 141 | 142 | #!perl 143 | 144 | use strict; 145 | use warnings; 146 | use Test::More tests => 4; 147 | use Audio::Chromaprint; 148 | 149 | { 150 | my $cp = Audio::Chromaprint->new(); 151 | 152 | isa_ok( $cp, 'Audio::Chromaprint' ); 153 | is( 154 | $cp->{'algorithm'}, 155 | 'test2', 156 | 'Constructor set correct default algorithm', 157 | ); 158 | } 159 | 160 | { 161 | my $cp = Audio::Chromaprint->new( 162 | algorithm => 'test3' 163 | ); 164 | 165 | isa_ok( $cp, 'Audio::Chromaprint' ); 166 | is( 167 | $cp->{'algorithm'}, 168 | 'test3', 169 | 'Constructor set correct algorithm from argument', 170 | ); 171 | } 172 | 173 | =head3 Running it 174 | 175 | $ make && make test TEST_VERBOSE=1 TEST_FILES="t/new.t" 176 | 177 | 1..4 178 | ok 1 - The object isa Audio::Chromaprint 179 | ok 2 - Constructor set correct default algorithm 180 | ok 3 - The object isa Audio::Chromaprint 181 | not ok 4 - Constructor set correct algorithm from argument 182 | 183 | # Failed test 'Constructor set correct algorithm from argument' 184 | # at t/new.t line 25. 185 | # got: 'test2' 186 | # expected: 'test3' 187 | # Looks like you failed 1 test of 4. 188 | Dubious, test returned 1 (wstat 256, 0x100) 189 | Failed 1/4 subtests 190 | 191 | We are now failing because we're not setting the attribute value using the 192 | argument provided by our test. We need to fix it. 193 | 194 | =head3 Checking the input better 195 | 196 | If we want to handle key/value pairs as input to the constructor, we need 197 | to have a better check of the input. What if we expect a pair and the user 198 | sends in a hash reference? What if it's an array reference? Let's be more 199 | explicit in what we allow before we try to analyze it. 200 | 201 | We will add the following piece of code after the B segment in our 202 | XSUB: 203 | 204 | CODE: 205 | /* check the number of input arguments */ 206 | /* "items" represents the argument count */ 207 | if ( ( items - 1 ) % 2 ) 208 | croak("Expecting key/value pairs as input to constructor\n"); 209 | 210 | // ... rest of code ... 211 | 212 | Should we test it? Yes, we should! 213 | 214 | =head3 Testing the limits 215 | 216 | We can simply add this following block to the F test file: 217 | 218 | use Test::Fatal; 219 | 220 | { 221 | like( 222 | exception { Audio::Chromaprint->new('SingleInput') }, 223 | qr{^Expecting key/value pairs as input to constructor}, 224 | 'Incorrect input for single item (instead of pairs)', 225 | ); 226 | 227 | like( 228 | exception { Audio::Chromaprint->new( 1, 2, 3 ) }, 229 | qr{^Expecting key/value pairs as input to constructor}, 230 | 'Incorrect input for odd items (instead of pairs)', 231 | ); 232 | 233 | is( 234 | exception { Audio::Chromaprint->new() }, 235 | undef, 236 | 'Successful at calling a constructor without arguments', 237 | ); 238 | 239 | is( 240 | exception { Audio::Chromaprint->new( key => 'value' ) }, 241 | undef, 242 | 'Successful at calling a constructor with even items', 243 | ); 244 | } 245 | 246 | # ... rest of tests ... 247 | 248 | And don't forget to update the test plan: 249 | 250 | use Test::More tests => 8; 251 | 252 | Trying it out... 253 | 254 | 1..8 255 | ok 1 - Incorrect input for single item (instead of pairs) 256 | ok 2 - Incorrect input for odd items (instead of pairs) 257 | ok 3 - Successful at calling a constructor without arguments 258 | ok 4 - Successful at calling a constructor with even items 259 | ok 5 - The object isa Audio::Chromaprint 260 | ok 6 - Constructor set correct default algorithm 261 | ok 7 - The object isa Audio::Chromaprint 262 | not ok 8 - Constructor set correct algorithm from argument 263 | 264 | # Failed test 'Constructor set correct algorithm from argument' 265 | # at t/new.t line 51. 266 | # got: 'test2' 267 | # expected: 'test3' 268 | # Looks like you failed 1 test of 8. 269 | Dubious, test returned 1 (wstat 256, 0x100) 270 | Failed 1/8 subtests 271 | 272 | Alright. It all passes, except for actually setting the value according to 273 | the input from the user. 274 | 275 | =head3 Looping over the Perl stack 276 | 277 | The Perl interpreter puts all the variables from the Perl side on a stack. 278 | The stack has pointers to Cs that represent what the user sent to the XSUB. 279 | Pretty simple. It's actually that simple to play with it too. 280 | 281 | Right after our code that goes over the items, we can loop over the stack 282 | (available using the C macro) and use the information there to add 283 | variables to the hash we created. 284 | 285 | Let's take a look at a simple example that will use C (which 286 | you can also find in L). We used the C function in the default 287 | because we had strings for the key and value. However, in this case, because 288 | we get Cs from the stack, we can use C, which allows us to 289 | store using Cs for key and value. 290 | 291 | This, however, will cause a problem, which we will see. 292 | 293 | CODE: 294 | if ( ( items - 1 ) % 2 ) 295 | croak("Expecting key/value pairs as input to constructor\n"); 296 | 297 | HV *hash = newHV(); 298 | 299 | hv_store( 300 | hash, /* created before */ 301 | "algorithm", /* key */ 302 | strlen("algorithm"), /* length */ 303 | newSVpv( "test2", strlen("test2") ), /* new SV with PV */ 304 | 0 /* let Perl calculate */ 305 | ); 306 | 307 | int i; 308 | for ( i = 1; i < items; i += 2 ) { 309 | /* get two items from the stack */ 310 | /* it starts from 1 in this case */ 311 | SV *key = ST(i); 312 | SV *value = ST( i + 1 ); 313 | 314 | /* store the value by key in the hash */ 315 | hv_store_ent( hash, key, value, 0 ); 316 | } 317 | 318 | /* ... rest of code ... */ 319 | 320 | =head3 Trying it out 321 | 322 | If we actually run this code, we will get this warning in our output: 323 | 324 | Attempt to free unreferenced scalar: SV 0x26f9ac0, Perl interpreter: 325 | 0x24c5010. 326 | 327 | The reason is simple, but the explanation can be a bit tricky to follow.[1] 328 | 329 | When we pick the C from the stack, it effectively has no actual references to it. Okay, 330 | I'm lying. It has one, which is the one from the op code, but that is likely 331 | to be confusing - better to think of it as I. 332 | 333 | This is why Perl actually releases it before it even exits the scope in which 334 | it's running in the test. When it exits the scope, it tries to release it yet 335 | again, but it fails, because it has already been released, hence the warning. 336 | 337 | If we read the documentation of C in C, it has the 338 | following sentence: I. 340 | 341 | So we can simply increment the reference count for the C. 342 | 343 | /* get two items from the stack */ 344 | /* it starts from 1 in this case */ 345 | SV *key = ST(i); 346 | SV *value = ST( i + 1 ); 347 | 348 | /* increment */ 349 | SvREFCNT_inc(value); 350 | 351 | Running the tests: 352 | 353 | t/new.t .. 354 | 1..8 355 | ok 1 - Incorrect input for single item (instead of pairs) 356 | ok 2 - Incorrect input for odd items (instead of pairs( 357 | ok 3 - Successful at calling a constructor without arguments 358 | ok 4 - Successful at calling a constructor with even items 359 | ok 5 - The object isa Audio::Chromaprint 360 | ok 6 - Constructor set correct default algorithm 361 | ok 7 - The object isa Audio::Chromaprint 362 | ok 8 - Constructor set correct algorithm from argument 363 | ok 364 | All tests successful. 365 | 366 | I<[1] If you find this confusing, please help me correct it!> 367 | 368 | =head2 More problems 369 | 370 | There is a side-effect we get here that, unless we understand how things 371 | work, will bite us at some point without us even realizing it. 372 | 373 | If you add the following to the C test code: 375 | 376 | $cp->{'algorithm'} = 'test1'; 377 | 378 | You will get the following output: 379 | 380 | ... 381 | ok 8 - Constructor set correct algorithm from argument 382 | Modification of a read-only value attempted at t/new.t line 57. 383 | # Looks like your test exited with 2 just after 8. 384 | Dubious, test returned 2 (wstat 512, 0x200) 385 | 386 | Wait, what? 387 | 388 | =head3 What's going on? 389 | 390 | When you store a value from XS using either C or 391 | C, Perl stores the passed C without making a copy (and 392 | discarding the previous value for that key, if present). On the other 393 | hand the code executed when assigning to the key from Perl fetches the 394 | current value C for that key (creating it if it is a new key) and 395 | changes its C with a C of the new string you wanted to assign. 396 | 397 | So if the C stored by C/C is read-only, this 398 | won't work. So how do we fix it? Well, we can do various different 399 | things: 400 | 401 | =over 4 402 | 403 | =item * Send a variable instead of a string 404 | 405 | Currently we use the C method like so: 406 | 407 | my $cp = Algorithm::Chromaprint->new( algorithm => 'test3' ); 408 | 409 | B here is a static string. It's not a variable. This is why if we 410 | dump the variable using C in the XS, as follows: 411 | 412 | SV *value = ST( i + 1 ); 413 | 414 | /* dump value */ 415 | sv_dump(value); 416 | 417 | we will get the following output: 418 | 419 | SV = PV(0x267ba70) at 0x26b3b00 420 | REFCNT = 1 421 | FLAGS = (PADTMP,POK,READONLY,pPOK) 422 | PV = 0x26bfaa0 "test3"\0 423 | CUR = 5 424 | LEN = 16 425 | 426 | (This is the same output you will get with L.) Note that this 427 | output was generated with Perl 5.14 and could differ slightly with the 428 | output from later Perl versions. 429 | 430 | You can see the B entry has B and B. This is 431 | because it's a temporary lexical variable and read-only. 432 | 433 | We can just send a variable instead: 434 | 435 | my $algo = 'test3'; 436 | my $cp = Audio::Chromaprint->new( algorithm => $algo ); 437 | 438 | But... do we really want to do it this way? No. We don't. Besides, we want to 439 | make sure the C has the right reference count. We're responsible for it. 440 | 441 | =item * Remove the READONLY flag 442 | 443 | While it's possible to simply 444 | disable the B restriction and then change the value anyway, this 445 | might cause action-at-a-distance behavior in the future, and we surely want 446 | to avoid such a risk. 447 | 448 | We do B want to do this. 449 | 450 | =item * Create a new C with the value 451 | 452 | The best way to handle it is to create a new C using the C we got from 453 | the stack. While the C from the stack will get freed automatically by Perl, 454 | we will provide our own independent C, which will not be read-only, and 455 | which could easily be added to the hash. 456 | 457 | =item * Do the same but manually 458 | 459 | What Perl does on assignment is fetch the C using C/C 460 | with the C flag set, get the C holding the current value for the key, 461 | and use one of the C macros to copy the contents of the C we got from 462 | the stack into the C returned by C/C. 463 | 464 | While this is more efficient than the alternative above, it is also 465 | convoluted, so we will keep it for a future chapter. 466 | 467 | =back 468 | 469 | =head3 Creating a new C 470 | 471 | To create a new C, we use C, which creates a new C from an 472 | existing C. This means that whether the user provided a value which is a 473 | string (PV), an integer (IV), or a double (NV), we will have it in the new 474 | C. 475 | 476 | SV *key = ST(i); 477 | SV *value = newSVsv( ST( i + 1 ) ); 478 | 479 | The call to C is no longer necessary. 480 | 481 | To ensure that this code behaves the way we intend it to, we add the 482 | following two tests after the C test: 484 | 485 | is( 486 | exception { $cp->{'algorithm'} = 'test1' }, 487 | undef, 488 | 'We can change the algorithm key directly', 489 | ); 490 | 491 | is( 492 | $cp->{'algorithm'}, 493 | 'test1', 494 | 'It was changed correctly', 495 | ); 496 | 497 | and update the test plan to match the new number of tests: 498 | 499 | use Test::More tests => 10; 500 | 501 | Running the tests, we should see that everything works. Yay! 502 | 503 | $ make && make test TEST_VERBOSE=1 TEST_FILES="t/new.t" 504 | 505 | 1..10 506 | ok 1 - Incorrect input for single item (instead of pairs) 507 | ok 2 - Incorrect input for odd items (instead of pairs( 508 | ok 3 - Successful at calling a constructor without arguments 509 | ok 4 - Successful at calling a constructor with even items 510 | ok 5 - An object of class 'Audio::Chromaprint' isa 'Audio::Chromaprint' 511 | ok 6 - Constructor set correct default algorithm 512 | ok 7 - An object of class 'Audio::Chromaprint' isa 'Audio::Chromaprint' 513 | ok 8 - Constructor set correct algorithm from argument 514 | ok 9 - We can change the algorithm key directly 515 | ok 10 - It was changed correctly 516 | ok 517 | All tests successful. 518 | 519 | =head2 Finishing 520 | 521 | =head3 Chromaprint.xs 522 | 523 | #define PERL_NO_GET_CONTEXT 524 | #include "EXTERN.h" 525 | #include "perl.h" 526 | #include "XSUB.h" 527 | #include "ppport.h" 528 | 529 | #include 530 | 531 | MODULE = Audio::Chromaprint PACKAGE = Audio::Chromaprint 532 | 533 | PROTOTYPES: ENABLED 534 | 535 | SV * 536 | new( const char *class, ... ) 537 | CODE: 538 | if ( ( items - 1 ) % 2 ) 539 | croak("Expecting key/value pairs as input to constructor"); 540 | 541 | HV *hash = newHV(); 542 | 543 | hv_store( 544 | hash, 545 | "algorithm", 546 | strlen("algorithm"), 547 | newSVpv( "test2", strlen("test2") ), 548 | 0 549 | ); 550 | 551 | int i; 552 | for ( i = 1; i < items; i += 2 ) { 553 | SV *key = ST(i); 554 | SV *value = newSVsv( ST( i + 1 ) ); 555 | 556 | hv_store_ent( hash, key, value, 0 ); 557 | } 558 | 559 | SV* const self = newRV_noinc( (SV *)hash ); 560 | 561 | RETVAL = sv_bless( self, gv_stashpv( class, 0 ) ); 562 | OUTPUT: RETVAL 563 | 564 | =head3 new.t 565 | 566 | #!perl 567 | 568 | use strict; 569 | use warnings; 570 | use Test::More tests => 10; 571 | use Test::Fatal; 572 | use Audio::Chromaprint; 573 | 574 | { 575 | like( 576 | exception { Audio::Chromaprint->new('SingleInput') }, 577 | qr{^Expecting key/value pairs as input to constructor}, 578 | 'Incorrect input for single item (instead of pairs)', 579 | ); 580 | 581 | like( 582 | exception { Audio::Chromaprint->new( 1, 2, 3 ) }, 583 | qr{^Expecting key/value pairs as input to constructor}, 584 | 'Incorrect input for odd items (instead of pairs(', 585 | ); 586 | 587 | is( 588 | exception { Audio::Chromaprint->new() }, 589 | undef, 590 | 'Successful at calling a constructor without arguments', 591 | ); 592 | 593 | is( 594 | exception { Audio::Chromaprint->new( key => 'value' ) }, 595 | undef, 596 | 'Successful at calling a constructor with even items', 597 | ); 598 | } 599 | 600 | { 601 | my $cp = Audio::Chromaprint->new(); 602 | 603 | isa_ok( $cp, 'Audio::Chromaprint' ); 604 | is( 605 | $cp->{'algorithm'}, 606 | 'test2', 607 | 'Constructor set correct default algorithm', 608 | ); 609 | } 610 | 611 | { 612 | my $cp = Audio::Chromaprint->new( 613 | algorithm => 'test3' 614 | ); 615 | 616 | isa_ok( $cp, 'Audio::Chromaprint' ); 617 | is( 618 | $cp->{'algorithm'}, 619 | 'test3', 620 | 'Constructor set correct algorithm from argument', 621 | ); 622 | 623 | is( 624 | exception { $cp->{'algorithm'} = 'test1' }, 625 | undef, 626 | 'We can change the algorithm key directly', 627 | ); 628 | 629 | is( 630 | $cp->{'algorithm'}, 631 | 'test1', 632 | 'It was changed correctly', 633 | ); 634 | } 635 | -------------------------------------------------------------------------------- /chapter_05/Audio-Chromaprint/Chromaprint.xs: -------------------------------------------------------------------------------- 1 | #define PERL_NO_GET_CONTEXT 2 | #include "EXTERN.h" 3 | #include "perl.h" 4 | #include "XSUB.h" 5 | #include "ppport.h" 6 | 7 | #include 8 | 9 | MODULE = Audio::Chromaprint PACKAGE = Audio::Chromaprint 10 | 11 | PROTOTYPES: ENABLED 12 | 13 | SV * 14 | new( const char *class, ... ) 15 | PREINIT: 16 | ChromaprintContext *chromaprint_ctx; 17 | 18 | CODE: 19 | if ( ( items - 1 ) % 2 ) 20 | croak("Expecting a hash as input to constructor"); 21 | 22 | HV *hash = newHV(); 23 | 24 | int i, algo = CHROMAPRINT_ALGORITHM_DEFAULT; 25 | for ( i = 1; i < items; i += 2 ) { 26 | SV *key = ST(i); 27 | SV *value = newSVsv( ST( i + 1 ) ); 28 | 29 | // we only store unless it's the algorithm 30 | // then we simply override the value and store it later 31 | if ( strcmp( SvPV_nolen( ST(i) ), "algorithm" ) == 0 ) { 32 | const char *algo_v = SvPV_nolen(value); 33 | // check algorithm options 34 | if (!strcmp( algo_v, "test1")) { 35 | algo = CHROMAPRINT_ALGORITHM_TEST1; 36 | } else if (!strcmp(algo_v, "test2")) { 37 | algo = CHROMAPRINT_ALGORITHM_TEST2; 38 | } else if (!strcmp(algo_v, "test3")) { 39 | algo = CHROMAPRINT_ALGORITHM_TEST3; 40 | } else if (!strcmp(algo_v, "test4")) { 41 | algo = CHROMAPRINT_ALGORITHM_TEST4; 42 | } else { 43 | warn("WARNING: unknown algorithm, using the default"); 44 | } 45 | } else { 46 | hv_store_ent( hash, key, value, 0 ); 47 | } 48 | } 49 | 50 | // store the algorithm 51 | hv_store( 52 | hash, 53 | "algorithm", 54 | strlen("algorithm"), 55 | newSViv(algo), 56 | 0 57 | ); 58 | 59 | // print chromaprint_ctx to a new chromaprint object 60 | chromaprint_ctx = chromaprint_new(algo); 61 | 62 | // store the pointer to the chromaprint object in the hash 63 | hv_store( 64 | hash, 65 | "_cp_ptr", 66 | strlen("_cp_ptr"), 67 | newSViv( PTR2IV(chromaprint_ctx) ), 68 | 0 69 | ); 70 | 71 | SV* const self = newRV_noinc( (SV *)hash ); 72 | 73 | RETVAL = sv_bless( self, gv_stashpv( class, 0 ) ); 74 | OUTPUT: RETVAL 75 | 76 | const char * 77 | version(SV *self) 78 | CODE: 79 | RETVAL = chromaprint_get_version(); 80 | OUTPUT: RETVAL 81 | -------------------------------------------------------------------------------- /chapter_05/Audio-Chromaprint/MANIFEST: -------------------------------------------------------------------------------- 1 | Chromaprint.xs 2 | lib/Audio/Chromaprint.pm 3 | Makefile.PL 4 | MANIFEST This list of files 5 | ppport.h 6 | t/leak.t 7 | t/version.t 8 | t/new.t 9 | -------------------------------------------------------------------------------- /chapter_05/Audio-Chromaprint/Makefile.PL: -------------------------------------------------------------------------------- 1 | use 5.008005; 2 | use ExtUtils::MakeMaker; 3 | WriteMakefile( 4 | NAME => 'Audio::Chromaprint', 5 | VERSION_FROM => 'lib/Audio/Chromaprint.pm', 6 | PREREQ_PM => { 'Test::More' => 0 }, 7 | ABSTRACT_FROM => 'lib/Audio/Chromaprint.pm', 8 | AUTHOR => 'You', 9 | LIBS => ['-lchromaprint'], 10 | DEFINE => '', 11 | INC => '-I.', 12 | OBJECT => '$(O_FILES)', 13 | ); 14 | 15 | -------------------------------------------------------------------------------- /chapter_05/Audio-Chromaprint/lib/Audio/Chromaprint.pm: -------------------------------------------------------------------------------- 1 | package Audio::Chromaprint; 2 | 3 | use strict; 4 | use warnings; 5 | use XSLoader; 6 | 7 | our $VERSION = '0.001'; 8 | 9 | XSLoader::load( 'Audio::Chromaprint', $VERSION ); 10 | 11 | 1; 12 | 13 | __END__ 14 | 15 | =head1 NAME 16 | 17 | Audio::Chromaprint - Interface to the Chromaprint library 18 | 19 | -------------------------------------------------------------------------------- /chapter_05/Audio-Chromaprint/t/leak.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 2; 6 | 7 | use_ok( 'Audio::Chromaprint' ); 8 | 9 | my $called = 0; 10 | package Audio::Chromaprint { 11 | sub DESTROY { 12 | $called++; 13 | } 14 | } 15 | 16 | { 17 | my $cp = Audio::Chromaprint->new; 18 | } 19 | 20 | cmp_ok( $called, '==', 1, 'Destruction successful' ); 21 | -------------------------------------------------------------------------------- /chapter_05/Audio-Chromaprint/t/new.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 9; 6 | use Test::Fatal; 7 | 8 | use_ok( 'Audio::Chromaprint' ); 9 | 10 | { 11 | like( 12 | exception { Audio::Chromaprint->new('SingleInput') }, 13 | qr/^Expecting a hash as input to constructor/, 14 | 'Incorrect input for single item (instead of pairs)', 15 | ); 16 | 17 | like( 18 | exception { Audio::Chromaprint->new( 1, 2, 3 ) }, 19 | qr/^Expecting a hash as input to constructor/, 20 | 'Incorrect input for odd items (instead of pairs)', 21 | ); 22 | 23 | is( 24 | exception { Audio::Chromaprint->new() }, 25 | undef, 26 | 'Successful at calling a constructor without arguments', 27 | ); 28 | 29 | is( 30 | exception { Audio::Chromaprint->new( key => 'value' ) }, 31 | undef, 32 | 'Successful at calling a constructor with even items', 33 | ); 34 | } 35 | 36 | { 37 | my $cp = Audio::Chromaprint->new(); 38 | 39 | isa_ok( $cp, 'Audio::Chromaprint' ); 40 | is( 41 | $cp->{'algorithm'}, 42 | 1, 43 | 'Constructor set correct default algorithm', 44 | ); 45 | } 46 | 47 | { 48 | my $cp = Audio::Chromaprint->new( 49 | algorithm => 'test3', 50 | ); 51 | 52 | isa_ok( $cp, 'Audio::Chromaprint' ); 53 | is( 54 | $cp->{'algorithm'}, 55 | 2, 56 | 'Constructor set correct algorithm from argument', 57 | ); 58 | } 59 | -------------------------------------------------------------------------------- /chapter_05/Audio-Chromaprint/t/version.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings; 4 | 5 | use Test::More tests => 4; 6 | 7 | use_ok( 'Audio::Chromaprint' ); 8 | 9 | my $cp = Audio::Chromaprint->new(); 10 | isa_ok( $cp, 'Audio::Chromaprint' ); 11 | can_ok( $cp, 'version' ); 12 | 13 | is( $cp->version, '1.2.0', 'chromaprint version is 1.2.0' ); 14 | 15 | -------------------------------------------------------------------------------- /chapter_05/chapter_05.pod: -------------------------------------------------------------------------------- 1 | =head1 Context: here we come 2 | 3 | =head2 Let's put this in context 4 | 5 | The B library uses a context struct. It's a structure which 6 | is very similar to an object in the sense that it stores contextual 7 | information the way objects store attributes. 8 | 9 | In order to use B functions, we need to create a context and 10 | then call functions with that context. This is very similar to the Perl 11 | interface we would like to have, except we can use methods, so the object 12 | is already available. 13 | 14 | If the library was Perl, it would like this: 15 | 16 | my $context = Chromaprint->new(...); 17 | my $algorithm = Chromaprint::algorithm($context); 18 | 19 | This is definitely not Perlish. We can make it fully object oriented by 20 | associating the Perl hash we create with the context object. We could 21 | then provide the following Perlish syntax: 22 | 23 | my $chromaprint_object = Chromaprint->new(...); 24 | my $algorithm = $chromaprint_object->algorithm; 25 | 26 | Because the C<< -> >> notation sends the invocant as the first parameter, 27 | the object hash will be sent to our C function and we could 28 | match that with the context we will create ourselves. 29 | 30 | In order to do that, we need to do two things: 31 | 32 | =over 4 33 | 34 | =item * Create a context struct 35 | 36 | =item * Associate it with the Perl hash 37 | 38 | =back 39 | 40 | =head2 Creating the struct 41 | 42 | Creating the struct is fairly simple. Let's take a look at the C 43 | function signature: 44 | 45 | CHROMAPRINT_API ChromaprintContext *chromaprint_new(int algorithm); 46 | 47 | The first part, C, is a macro. The interesting part comes 48 | after. 49 | 50 | In order to create a chromaprint struct, we start by creating a pointer 51 | of type C and send the C function 52 | the algorithm, as an C. 53 | 54 | We can do that in XS too. First we can use the C section to 55 | define a variable before our C gets called. 56 | 57 | PREINIT: 58 | ChromaprintContext *chromaprint_ctx; 59 | 60 | CODE: 61 | ... 62 | 63 | This provides us with a pointer of the right structure type. It doesn't 64 | point to anything yet. 65 | 66 | In order to make it point to something, we need to create a new struct 67 | for the chromaprint. We can use the C function provided 68 | by the Chromaprint library. 69 | 70 | chromaprint_ctx = chromaprint_new(algo); 71 | 72 | You might notice two problems here. The first one would be, "Where is 73 | C from?" and the second, "What happens to the variable when we 74 | finish the C method?" 75 | 76 | =head2 Algorithm 77 | 78 | Originally in our code, we had the algorithm option sent. We kept it in 79 | the hash the way it was sent, and we put C as the default value, 80 | but now we need to get smarter. 81 | 82 | Because the algorithm variable is an C and we want to allow strings 83 | being sent, we will need to translate the string to the appropriate 84 | integer. 85 | 86 | First we create a default algorithm, and we will use a constant from 87 | the library to accomplish that: 88 | 89 | int i, algo = CHROMAPRINT_ALGORITHM_DEFAULT; 90 | 91 | Now we loop over the items, just like we did before: 92 | 93 | for ( i = 1; i < items; i += 2 ) { 94 | SV *key = ST(i); 95 | SV *value = newSVsv( ST( i + 1 ) ); 96 | 97 | And now we start checking if we received an algorithm, and if so, we 98 | overwrite the algorithm variable. If it's not an algorithm, we store it. 99 | 100 | // we only store unless it's the algorithm 101 | // then we simply override the value and store it later 102 | if ( strcmp( SvPV_nolen( ST(i) ), "algorithm" ) == 0 ) { 103 | const char *algo_v = SvPV_nolen(value); 104 | // check algorithm options 105 | if (!strcmp( algo_v, "test1")) { 106 | algo = CHROMAPRINT_ALGORITHM_TEST1; 107 | } else if (!strcmp(algo_v, "test2")) { 108 | algo = CHROMAPRINT_ALGORITHM_TEST2; 109 | } else if (!strcmp(algo_v, "test3")) { 110 | algo = CHROMAPRINT_ALGORITHM_TEST3; 111 | } else if (!strcmp(algo_v, "test4")) { 112 | algo = CHROMAPRINT_ALGORITHM_TEST4; 113 | } else { 114 | warn("WARNING: unknown algorithm, using the default"); 115 | } 116 | } else { 117 | // no validation necessary here, just store it. 118 | hv_store_ent( hash, key, value, 0 ); 119 | } 120 | 121 | Why do we only overwrite the C variable instead of simply storing 122 | it? Imagine the following code: 123 | 124 | my $chromaprint = Audio::Chromaprint->new(); 125 | 126 | If we check the algorithm only within the loop of keys, we won't spot that 127 | one was not provided. 128 | 129 | Another approach is to store everything, no matter what, then check the 130 | value from the hash and change it if missing. 131 | 132 | We can also first create the hash with the default algorithm and then 133 | override if it's available in the options. That will force two writings 134 | to the hash instead of a single one. 135 | 136 | Since the algorithm is an integer and not a string, we correct the 137 | following statement: 138 | 139 | hv_store( 140 | hash, 141 | "algorithm", 142 | strlen("algorithm"), 143 | newSViv(algo), 144 | 0 145 | ); 146 | 147 | Excellent! 148 | 149 | =head2 Knowing the context 150 | 151 | Now that we have the context, even when the function is done, it will 152 | still be in memory, but we won't have the pointer anymore. They pointer 153 | will go away but the context struct will live on. We need a way to be 154 | able to find it back. 155 | 156 | Since pointers are basically addresses, we can print out the address 157 | number. 158 | 159 | printf("Context pointer address: %p\n", chromaprint_ctx); 160 | 161 | In the output we will get: 162 | 163 | Context pointer address: 0x1a7c040 164 | 165 | This is hexadecimal but we can get the integer value of it, and we can 166 | save value in the hash we return to the user. Then when another method is 167 | called, it can fetch the pointer address from the hash value and call 168 | additional Chromaprint functions with it. 169 | 170 | hv_store( 171 | hash, 172 | "_cp_str", 173 | strlen("_cp_str"), 174 | newSViv( PTR2IV(chromaprint_ctx) ), 175 | 0 176 | ); 177 | 178 | Let's try to print out the object we get from the XS C method: 179 | 180 | use DDP; 181 | my $cp = Audio::Chromaprint->new(); 182 | p $cp; 183 | 184 | The output: 185 | 186 | Audio::Chromaprint { 187 | public methods (4) : algorithm, bootstrap, new, version 188 | private methods (0) 189 | internals: { 190 | algorithm "test1", 191 | _cp_ptr 27770944 192 | } 193 | } 194 | -------------------------------------------------------------------------------- /chapter_06/Audio-Chromaprint/Chromaprint.xs: -------------------------------------------------------------------------------- 1 | #define PERL_NO_GET_CONTEXT 2 | #include "EXTERN.h" 3 | #include "perl.h" 4 | #include "XSUB.h" 5 | #include "ppport.h" 6 | 7 | #include 8 | 9 | MODULE = Audio::Chromaprint PACKAGE = Audio::Chromaprint 10 | 11 | PROTOTYPES: ENABLED 12 | 13 | SV * 14 | new( const char *class, ... ) 15 | PREINIT: 16 | ChromaprintContext *chromaprint_ctx; 17 | 18 | CODE: 19 | if ( ( items - 1 ) % 2 ) 20 | croak("Expecting a hash as input to constructor"); 21 | 22 | HV *hash = newHV(); 23 | 24 | int i, algo = CHROMAPRINT_ALGORITHM_DEFAULT; 25 | for ( i = 1; i < items; i += 2 ) { 26 | SV *key = ST(i); 27 | SV *value = newSVsv( ST( i + 1 ) ); 28 | 29 | // we only store unless it's the algorithm 30 | // then we simply override the value and store it later 31 | if ( strcmp( SvPV_nolen( ST(i) ), "algorithm" ) == 0 ) { 32 | const char *algo_v = SvPV_nolen(value); 33 | // check algorithm options 34 | if (!strcmp( algo_v, "test1")) { 35 | algo = CHROMAPRINT_ALGORITHM_TEST1; 36 | } else if (!strcmp(algo_v, "test2")) { 37 | algo = CHROMAPRINT_ALGORITHM_TEST2; 38 | } else if (!strcmp(algo_v, "test3")) { 39 | algo = CHROMAPRINT_ALGORITHM_TEST3; 40 | } else if (!strcmp(algo_v, "test4")) { 41 | algo = CHROMAPRINT_ALGORITHM_TEST4; 42 | } else { 43 | warn("WARNING: unknown algorithm, using the default"); 44 | } 45 | } else { 46 | hv_store_ent( hash, key, value, 0 ); 47 | } 48 | } 49 | 50 | // store the algorithm 51 | hv_store( 52 | hash, 53 | "algorithm", 54 | strlen("algorithm"), 55 | newSViv(algo), 56 | FALSE 57 | ); 58 | 59 | // print chromaprint_ctx to a new chromaprint object 60 | chromaprint_ctx = chromaprint_new(algo); 61 | 62 | // set all variables in the chromaprint object 63 | const char *s_threshold = "silence_threshold"; 64 | if ( hv_exists( hash, s_threshold, strlen(s_threshold) ) ) { 65 | SV **s_threshold_val = hv_fetch( hash, s_threshold, strlen(s_threshold), FALSE ); 66 | chromaprint_set_option( 67 | chromaprint_ctx, 68 | s_threshold, 69 | SvIV( *s_threshold_val ) 70 | ); 71 | } 72 | 73 | // store the pointer to the chromaprint object in the hash 74 | // user plays with it, it breaks 75 | hv_store( 76 | hash, 77 | "_cp_ptr", 78 | strlen("_cp_ptr"), 79 | newSViv( PTR2IV(chromaprint_ctx) ), 80 | FALSE 81 | ); 82 | 83 | SV* const self = newRV_noinc( (SV *)hash ); 84 | 85 | RETVAL = sv_bless( self, gv_stashpv( class, 0 ) ); 86 | OUTPUT: RETVAL 87 | 88 | const char * 89 | version(SV *self) 90 | CODE: 91 | RETVAL = chromaprint_get_version(); 92 | OUTPUT: RETVAL 93 | 94 | SV * 95 | algorithm(SV *self) 96 | PREINIT: 97 | const char *key = "algorithm"; 98 | SV **svp; 99 | 100 | CODE: 101 | RETVAL = &PL_sv_undef; 102 | 103 | if ( !SvROK(self) ) 104 | croak("type parameter is not a reference"); 105 | 106 | svp = hv_fetch( (HV *)SvRV(self), key, strlen(key), FALSE ); 107 | 108 | if ( svp && SvOK(*svp) ) 109 | RETVAL = newSVsv(*svp); 110 | 111 | OUTPUT: RETVAL 112 | 113 | void 114 | DESTROY(SV *self) 115 | PREINIT: 116 | ChromaprintContext *ctx; 117 | HV *hash; 118 | 119 | CODE: 120 | hash = (HV *)SvRV(self); 121 | ctx = (ChromaprintContext *) SvIV( 122 | *hv_fetchs( hash, "_cp_ptr", FALSE ) 123 | ); 124 | 125 | chromaprint_free(ctx); 126 | -------------------------------------------------------------------------------- /chapter_06/Audio-Chromaprint/MANIFEST: -------------------------------------------------------------------------------- 1 | Chromaprint.xs 2 | lib/Audio/Chromaprint.pm 3 | Makefile.PL 4 | MANIFEST This list of files 5 | ppport.h 6 | t/new.t 7 | t/leak.t 8 | t/leak-pointer.t 9 | t/version.t 10 | -------------------------------------------------------------------------------- /chapter_06/Audio-Chromaprint/Makefile.PL: -------------------------------------------------------------------------------- 1 | use 5.008005; 2 | use ExtUtils::MakeMaker; 3 | WriteMakefile( 4 | NAME => 'Audio::Chromaprint', 5 | VERSION_FROM => 'lib/Audio/Chromaprint.pm', 6 | PREREQ_PM => { 'Test::More' => 0 }, 7 | ABSTRACT_FROM => 'lib/Audio/Chromaprint.pm', 8 | AUTHOR => 'You', 9 | LIBS => ['-lchromaprint'], 10 | DEFINE => '', 11 | INC => '-I.', 12 | OBJECT => '$(O_FILES)', 13 | ); 14 | 15 | -------------------------------------------------------------------------------- /chapter_06/Audio-Chromaprint/lib/Audio/Chromaprint.pm: -------------------------------------------------------------------------------- 1 | package Audio::Chromaprint; 2 | 3 | use strict; 4 | use warnings; 5 | use XSLoader; 6 | 7 | our $VERSION = '0.001'; 8 | 9 | XSLoader::load( 'Audio::Chromaprint', $VERSION ); 10 | 11 | 1; 12 | 13 | __END__ 14 | 15 | =head1 NAME 16 | 17 | Audio::Chromaprint - Interface to the Chromaprint library 18 | 19 | -------------------------------------------------------------------------------- /chapter_06/Audio-Chromaprint/t/leak-pointer.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 2; 6 | use Test::MemoryGrowth; 7 | 8 | use_ok( 'Audio::Chromaprint' ); 9 | 10 | no_growth { Audio::Chromaprint->new; } 'Does not grow in memory'; 11 | -------------------------------------------------------------------------------- /chapter_06/Audio-Chromaprint/t/leak.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 2; 6 | 7 | use_ok( 'Audio::Chromaprint' ); 8 | 9 | my $called = 0; 10 | package My::Audio::Chromaprint { 11 | use parent 'Audio::Chromaprint'; 12 | sub DESTROY { 13 | $called++; 14 | my $self = shift; 15 | $self->SUPER::DESTROY(@_); 16 | } 17 | } 18 | 19 | { 20 | my $cp = My::Audio::Chromaprint->new; 21 | } 22 | 23 | cmp_ok( $called, '==', 1, 'Destruction successful' ); 24 | -------------------------------------------------------------------------------- /chapter_06/Audio-Chromaprint/t/new.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 11; 6 | use Test::Fatal; 7 | 8 | use_ok( 'Audio::Chromaprint' ); 9 | 10 | { 11 | like( 12 | exception { Audio::Chromaprint->new('SingleInput') }, 13 | qr/^Expecting a hash as input to constructor/, 14 | 'Incorrect input for single item (instead of pairs)', 15 | ); 16 | 17 | like( 18 | exception { Audio::Chromaprint->new( 1, 2, 3 ) }, 19 | qr/^Expecting a hash as input to constructor/, 20 | 'Incorrect input for odd items (instead of pairs)', 21 | ); 22 | 23 | is( 24 | exception { Audio::Chromaprint->new() }, 25 | undef, 26 | 'Successful at calling a constructor without arguments', 27 | ); 28 | 29 | is( 30 | exception { Audio::Chromaprint->new( key => 'value' ) }, 31 | undef, 32 | 'Successful at calling a constructor with even items', 33 | ); 34 | } 35 | 36 | { 37 | my $cp = Audio::Chromaprint->new(); 38 | 39 | isa_ok( $cp, 'Audio::Chromaprint' ); 40 | can_ok( $cp, 'algorithm' ); 41 | 42 | is( 43 | $cp->{'algorithm'}, 44 | $cp->algorithm, 45 | 'No algorithm key', 46 | ); 47 | 48 | is( 49 | $cp->algorithm, 50 | 1, 51 | 'Constructor set correct default algorithm', 52 | ); 53 | } 54 | 55 | { 56 | my $cp = Audio::Chromaprint->new( 57 | algorithm => 'test3', 58 | ); 59 | 60 | isa_ok( $cp, 'Audio::Chromaprint' ); 61 | is( 62 | $cp->algorithm, 63 | 2, 64 | 'Constructor set correct algorithm from argument', 65 | ); 66 | } 67 | -------------------------------------------------------------------------------- /chapter_06/Audio-Chromaprint/t/version.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings; 4 | 5 | use Test::More tests => 4; 6 | 7 | use_ok( 'Audio::Chromaprint' ); 8 | 9 | my $cp = Audio::Chromaprint->new(); 10 | isa_ok( $cp, 'Audio::Chromaprint' ); 11 | can_ok( $cp, 'version' ); 12 | 13 | is( $cp->version, '1.2.0', 'chromaprint version is 1.2.0' ); 14 | -------------------------------------------------------------------------------- /chapter_06/chapter_06.pod: -------------------------------------------------------------------------------- 1 | =head1 Tightening up 2 | 3 | =head2 A few loose ends 4 | 5 | There are two glaring loose ends in the previous chapter. You might have 6 | noticed them yourself. 7 | 8 | First of all, we don't clean up the pointer we created. We create a struct 9 | and point to it, but we never actually cleaned that up. We will need to 10 | introduce a C method. We should probably also test everything. 11 | 12 | Secondly, we should expose the algorithm method so our users don't have to 13 | dig into the object as a hash, thus breaking encapsulation. 14 | 15 | Lastly, there is a constructor parameter which we haven't used that the 16 | user can set in the API. We should support that. 17 | 18 | =head2 The destructor 19 | 20 | Once we create a struct, we are in charge of cleaning it up. Perl won't 21 | do that for us - at least not in this case. However, Perl can help us by 22 | calling a function for us when we should be cleaning up the struct. 23 | That's the C method and Perl calls it when it cleans up a 24 | variable. In this case the variable will be the object we create. 25 | 26 | In order to cleanup our struct, we can simply implement C. 27 | 28 | We'll start by defining the method: 29 | 30 | void 31 | DESTROY(SV *self) 32 | 33 | Now we can use the B section to define variables, which is less 34 | error-prone than defining them in the B section. 35 | 36 | PREINIT: 37 | ChromaprintContext *ctx; 38 | HV *hash; 39 | 40 | Now, finally the B section. We will need to dereference the hash 41 | and then point the pointer to the address where we created the Chromaprint 42 | context variable that the blessed hashref we use as an object has in its 43 | hash key under an IV. Wow, that's a mouthful. 44 | 45 | Basically we take the object (which is a hashref), dig inside it for the 46 | proper key where we stored the pointer address, and use is to point the 47 | new pointer to. 48 | 49 | CODE: 50 | hash = (HV *)SvRV(self); 51 | ctx = (ChromaprintContext *) SvIV( 52 | *hv_fetchs( hash, "_cp_ptr", FALSE ) 53 | ); 54 | 55 | You might notice we're using C instead of C<0> here, as it has a 56 | clearer boolean usage here. 57 | 58 | Now, since we instantiated the struct using Chromaprint, we will also free 59 | it using it: 60 | 61 | chromaprint_free(ctx); 62 | 63 | That's it. Altogether, the C method is simply this: 64 | 65 | void 66 | DESTROY(SV *self) 67 | PREINIT: 68 | ChromaprintContext *ctx; 69 | HV *hash; 70 | 71 | CODE: 72 | hash = (HV *)SvRV(self); 73 | ctx = (ChromaprintContext *) SvIV( 74 | *hv_fetchs( hash, "_cp_ptr", FALSE ) 75 | ); 76 | chromaprint_free(ctx); 77 | 78 | We can also write a simple test for it: 79 | 80 | use strict; 81 | use warnings; 82 | use Test::More tests => 2; 83 | use Test::MemoryGrowth; 84 | 85 | use_ok( 'Audio::Chromaprint' ); 86 | no_growth { Audio::Chromaprint->new; } 'Does not grow in memory'; 87 | 88 | Simple as that. 89 | 90 | Except... we do have a test already in which we're defining the C 91 | method, which means we'll get a warning that we're redefining it (once in 92 | the XS code, and once in the test). 93 | 94 | We can fix that by creating a new class which will subclass the original 95 | one, and create its own DESTROY. After using it to check for circular 96 | referencing, we can call the original C method: 97 | 98 | use strict; 99 | use warnings; 100 | use Test::More tests => 2; 101 | 102 | use_ok( 'Audio::Chromaprint' ); 103 | 104 | my $called = 0; 105 | package My::Audio::Chromaprint { 106 | use parent 'Audio::Chromaprint'; 107 | sub DESTROY { 108 | $called++; 109 | my $self = shift; 110 | $self->SUPER::DESTROY(@_); 111 | } 112 | } 113 | 114 | { 115 | my $cp = My::Audio::Chromaprint->new; 116 | } 117 | 118 | cmp_ok( $called, '==', 1, 'Destruction successful' ); 119 | 120 | Here we are using C to call the C method of our 121 | parent class. 122 | 123 | =head2 Algorithm from context 124 | 125 | Considering Chromaprint has a function declared called 126 | C, writing a method which calls it would be 127 | simple. We just need to use the same trick of having a new pointer point 128 | to the context we had already created - the one we used in the C 129 | method above: 130 | 131 | SV * 132 | algorithm(SV *self) 133 | PREINIT: 134 | ChromaprintContext *ctx; 135 | HV *hash; 136 | CODE: 137 | hash = (HV *)SvRV(self); 138 | ctx = (ChromaprintContext *) SvIV( 139 | *hv_fetchs( hash, "_cp_ptr", FALSE ) 140 | ); 141 | RETVAL = chromaprint_get_algorithm(ctx); 142 | OUTPUT: RETVAL 143 | 144 | This compiles alright, but if we try to run it, uh oh! Look at this 145 | output: 146 | 147 | t/version.t ....... 1/4 148 | # Failed test 'use Audio::Chromaprint;' 149 | # at t/version.t line 7. 150 | # Tried to use 'Audio::Chromaprint'. 151 | # Error: Can't load '.../Chromaprint.so' for module Audio::Chromaprint: .../Chromaprint.so: undefined symbol: chromaprint_get_algorithm at /usr/lib/perl/5.18/DynaLoader.pm line 184. 152 | # at t/version.t line 7. 153 | # Compilation failed in require at t/version.t line 7. 154 | # BEGIN failed--compilation aborted at t/version.t line 7. 155 | Can't locate object method "new" via package "Audio::Chromaprint" at t/version.t line 9. 156 | 157 | I<(and this is the cleaned output...)> 158 | 159 | The problem appears at the end of the I line. It says 160 | I. I'll admit this took 161 | baffled me personally quite a bit, until I ran the following command, to 162 | see all the defined symbols: 163 | 164 | $ readelf -Ws /usr/lib/x86_64-linux-gnu/libchromaprint.so.0.2.3 | grep chromaprint 165 | 166 | The output of this command showed a few functions, but 167 | C was not one of them. So no longer baffled, 168 | I was now definitely confused. 169 | 170 | Thankfully Mattia Barbon came to my help: 171 | I<"The function is not implemented">, he simply said. Without checking 172 | thoroughly, I had noticed the function definition in the header file, but 173 | the function, however, doesn't actually exist - its implementation. 174 | 175 | This results in compilation working, linking working, but eventually 176 | calling the function (which happened in that test) failing. 177 | 178 | Okay, so we can't use this function, but we can still provide a method of 179 | our own to access the hash key. That's the basic way of doing it in Perl, 180 | so let's do that. 181 | 182 | The way we will do this is very simple: We fetch from the object the 183 | key value, and we serve to the user an B representing that value. We 184 | can't serve the B itself, we need to create our own. Then we'll add 185 | checks which we pretty much ignored up until now. 186 | 187 | First our B block will define the variables: the key as a string 188 | so we don't have to repeat it (no need for a defined constant yet) and a 189 | pointer to an B pointer, because that's what the C function 190 | we will use returns: 191 | 192 | SV * 193 | algorithm(SV *self) 194 | PREINIT: 195 | const char *key = "algorithm"; 196 | SV **svp; 197 | 198 | Now the code, at first, simply fetches and returns a new B based 199 | on what we got back from C. 200 | 201 | CODE: 202 | svp = hv_fetch( (HV *)SvRV(self), key, strlen(key), FALSE ); 203 | RETVAL = newSVsv(*svp); 204 | 205 | OUTPUT: RETVAL 206 | 207 | Now the checks. What if we didn't get a reference as a parameter? What 208 | if we didn't get a good value back from the hash key? 209 | 210 | We'll start by setting the B to an undef. That way, we either 211 | return a good value or undef. Then we check whether we got a reference 212 | or not, and we also check the value we got back for a proper B. 213 | 214 | CODE: 215 | RETVAL = &PL_sv_undef; 216 | 217 | if ( !SvROK(self) ) 218 | croak("type parameter is not a reference"); 219 | 220 | svp = hv_fetch( (HV *)SvRV(self), key, strlen(key), FALSE ); 221 | 222 | if ( svp && SvOK(*svp) ) 223 | RETVAL = newSVsv(*svp); 224 | 225 | Done! 226 | 227 | =head2 Completing the constructor 228 | 229 | Last loose end is the options you can send to the Chromaprint constructor. 230 | We currently don't send anything, although it is possible. Right now it 231 | seems the only option is the I. We can add this piece 232 | of code in our constructor after we create a new Chromaprint context: 233 | 234 | const char *s_threshold = "silence_threshold"; 235 | if ( hv_exists( hash, s_threshold, strlen(s_threshold) ) ) { 236 | SV **s_threshold_val = hv_fetch( hash, s_threshold, strlen(s_threshold), FALSE ); 237 | chromaprint_set_option( 238 | chromaprint_ctx, 239 | s_threshold, 240 | SvIV( *s_threshold_val ) 241 | ); 242 | } 243 | 244 | 245 | Simple. 246 | 247 | =head2 Mapping our types 248 | 249 | The next chapter in our journey will be B, which are ways for 250 | us to tell Perl's XS compiler how to automatically map types, so we don't 251 | have to handle all the conversion in our code. 252 | -------------------------------------------------------------------------------- /chapter_07/Audio-Chromaprint/Chromaprint.xs: -------------------------------------------------------------------------------- 1 | #define PERL_NO_GET_CONTEXT 2 | #include "EXTERN.h" 3 | #include "perl.h" 4 | #include "XSUB.h" 5 | #include "ppport.h" 6 | 7 | #include 8 | 9 | typedef struct { 10 | int algorithm; 11 | ChromaprintContext* cp_ctx; 12 | } CTX; 13 | 14 | MODULE = Audio::Chromaprint PACKAGE = Audio::Chromaprint 15 | 16 | PROTOTYPES: ENABLED 17 | 18 | SV * 19 | new( const char *class, ... ) 20 | PREINIT: 21 | CTX* ctx = (CTX *)malloc( sizeof(CTX) ); 22 | 23 | CODE: 24 | if ( ( items - 1 ) % 2 ) 25 | croak("Expecting a hash as input to constructor"); 26 | 27 | HV *hash = newHV(); 28 | 29 | int i, algo = CHROMAPRINT_ALGORITHM_DEFAULT; 30 | for ( i = 1; i < items; i += 2 ) { 31 | SV *key = ST(i); 32 | SV *value = newSVsv( ST( i + 1 ) ); 33 | 34 | // we only store unless it's the algorithm 35 | // then we simply override the value and store it later 36 | if ( strcmp( SvPV_nolen( ST(i) ), "algorithm" ) == 0 ) { 37 | const char *algo_v = SvPV_nolen(value); 38 | // check algorithm options 39 | if (!strcmp( algo_v, "test1")) { 40 | algo = CHROMAPRINT_ALGORITHM_TEST1; 41 | } else if (!strcmp(algo_v, "test2")) { 42 | algo = CHROMAPRINT_ALGORITHM_TEST2; 43 | } else if (!strcmp(algo_v, "test3")) { 44 | algo = CHROMAPRINT_ALGORITHM_TEST3; 45 | } else if (!strcmp(algo_v, "test4")) { 46 | algo = CHROMAPRINT_ALGORITHM_TEST4; 47 | } else { 48 | warn("WARNING: unknown algorithm, using the default"); 49 | } 50 | } else { 51 | hv_store_ent( hash, key, value, 0 ); 52 | } 53 | } 54 | 55 | ctx->cp_ctx = chromaprint_new(algo); 56 | ctx->algorithm = algo; 57 | 58 | // set all variables in the chromaprint object 59 | const char *s_threshold = "silence_threshold"; 60 | if ( hv_exists( hash, s_threshold, strlen(s_threshold) ) ) { 61 | SV **s_threshold_val = hv_fetch( hash, s_threshold, strlen(s_threshold), FALSE ); 62 | chromaprint_set_option( 63 | ctx->cp_ctx, 64 | s_threshold, 65 | SvIV( *s_threshold_val ) 66 | ); 67 | } 68 | 69 | // store the pointer to the chromaprint object in the hash 70 | // user plays with it, it breaks 71 | hv_store( 72 | hash, 73 | "_cp_ptr", 74 | strlen("_cp_ptr"), 75 | newSViv( PTR2IV(ctx) ), 76 | FALSE 77 | ); 78 | 79 | SV* const self = newRV_noinc( (SV *)hash ); 80 | 81 | RETVAL = sv_bless( self, gv_stashpv( class, 0 ) ); 82 | OUTPUT: RETVAL 83 | 84 | const char * 85 | version(SV *self) 86 | CODE: 87 | RETVAL = chromaprint_get_version(); 88 | OUTPUT: RETVAL 89 | 90 | SV * 91 | algorithm(SV *self) 92 | PREINIT: 93 | const char *key = "_cp_ptr"; 94 | SV **svp; 95 | CTX *ctx; 96 | 97 | CODE: 98 | RETVAL = &PL_sv_undef; 99 | 100 | if ( !SvROK(self) ) 101 | croak("type parameter is not a reference"); 102 | 103 | svp = hv_fetch( (HV *)SvRV(self), key, strlen(key), FALSE ); 104 | 105 | if ( svp && SvOK(*svp) ) { 106 | ctx = (CTX *) SvIV(*svp); 107 | RETVAL = newSViv( ctx->algorithm ); 108 | } 109 | 110 | OUTPUT: RETVAL 111 | 112 | void 113 | DESTROY(SV *self) 114 | PREINIT: 115 | CTX *ctx; 116 | SV **svp; 117 | HV *hash; 118 | 119 | CODE: 120 | hash = (HV *)SvRV(self); 121 | svp = hv_fetchs( hash, "_cp_ptr", FALSE ); 122 | 123 | if ( svp && SvOK(*svp) ) { 124 | ctx = (CTX *) SvIV(*svp); 125 | chromaprint_free( ctx->cp_ctx ); 126 | free(ctx); 127 | } 128 | -------------------------------------------------------------------------------- /chapter_07/Audio-Chromaprint/MANIFEST: -------------------------------------------------------------------------------- 1 | Chromaprint.xs 2 | lib/Audio/Chromaprint.pm 3 | Makefile.PL 4 | MANIFEST This list of files 5 | ppport.h 6 | t/new.t 7 | t/leak.t 8 | t/leak-pointer.t 9 | t/version.t 10 | -------------------------------------------------------------------------------- /chapter_07/Audio-Chromaprint/Makefile.PL: -------------------------------------------------------------------------------- 1 | use 5.008005; 2 | use ExtUtils::MakeMaker; 3 | WriteMakefile( 4 | NAME => 'Audio::Chromaprint', 5 | VERSION_FROM => 'lib/Audio/Chromaprint.pm', 6 | PREREQ_PM => { 'Test::More' => 0 }, 7 | ABSTRACT_FROM => 'lib/Audio/Chromaprint.pm', 8 | AUTHOR => 'You', 9 | LIBS => ['-lchromaprint'], 10 | DEFINE => '', 11 | INC => '-I.', 12 | OBJECT => '$(O_FILES)', 13 | ); 14 | 15 | -------------------------------------------------------------------------------- /chapter_07/Audio-Chromaprint/lib/Audio/Chromaprint.pm: -------------------------------------------------------------------------------- 1 | package Audio::Chromaprint; 2 | 3 | use strict; 4 | use warnings; 5 | use XSLoader; 6 | 7 | our $VERSION = '0.001'; 8 | 9 | XSLoader::load( 'Audio::Chromaprint', $VERSION ); 10 | 11 | 1; 12 | 13 | __END__ 14 | 15 | =head1 NAME 16 | 17 | Audio::Chromaprint - Interface to the Chromaprint library 18 | 19 | -------------------------------------------------------------------------------- /chapter_07/Audio-Chromaprint/t/leak-pointer.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 2; 6 | use Test::MemoryGrowth; 7 | 8 | use_ok( 'Audio::Chromaprint' ); 9 | 10 | no_growth { Audio::Chromaprint->new; } 'Does not grow in memory'; 11 | -------------------------------------------------------------------------------- /chapter_07/Audio-Chromaprint/t/leak.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 2; 6 | 7 | use_ok( 'Audio::Chromaprint' ); 8 | 9 | my $called = 0; 10 | package My::Audio::Chromaprint { 11 | use parent 'Audio::Chromaprint'; 12 | sub DESTROY { 13 | $called++; 14 | my $self = shift; 15 | $self->SUPER::DESTROY(@_); 16 | } 17 | } 18 | 19 | { 20 | my $cp = My::Audio::Chromaprint->new; 21 | } 22 | 23 | cmp_ok( $called, '==', 1, 'Destruction successful' ); 24 | -------------------------------------------------------------------------------- /chapter_07/Audio-Chromaprint/t/new.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 10; 6 | use Test::Fatal; 7 | 8 | use_ok( 'Audio::Chromaprint' ); 9 | 10 | { 11 | like( 12 | exception { Audio::Chromaprint->new('SingleInput') }, 13 | qr/^Expecting a hash as input to constructor/, 14 | 'Incorrect input for single item (instead of pairs)', 15 | ); 16 | 17 | like( 18 | exception { Audio::Chromaprint->new( 1, 2, 3 ) }, 19 | qr/^Expecting a hash as input to constructor/, 20 | 'Incorrect input for odd items (instead of pairs)', 21 | ); 22 | 23 | is( 24 | exception { Audio::Chromaprint->new() }, 25 | undef, 26 | 'Successful at calling a constructor without arguments', 27 | ); 28 | 29 | is( 30 | exception { Audio::Chromaprint->new( key => 'value' ) }, 31 | undef, 32 | 'Successful at calling a constructor with even items', 33 | ); 34 | } 35 | 36 | { 37 | my $cp = Audio::Chromaprint->new(); 38 | 39 | isa_ok( $cp, 'Audio::Chromaprint' ); 40 | can_ok( $cp, 'algorithm' ); 41 | 42 | is( 43 | $cp->algorithm, 44 | 1, 45 | 'Constructor set correct default algorithm', 46 | ); 47 | } 48 | 49 | { 50 | my $cp = Audio::Chromaprint->new( 51 | algorithm => 'test3', 52 | ); 53 | 54 | isa_ok( $cp, 'Audio::Chromaprint' ); 55 | is( 56 | $cp->algorithm, 57 | 2, 58 | 'Constructor set correct algorithm from argument', 59 | ); 60 | } 61 | -------------------------------------------------------------------------------- /chapter_07/Audio-Chromaprint/t/version.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings; 4 | 5 | use Test::More tests => 4; 6 | 7 | use_ok( 'Audio::Chromaprint' ); 8 | 9 | my $cp = Audio::Chromaprint->new(); 10 | isa_ok( $cp, 'Audio::Chromaprint' ); 11 | can_ok( $cp, 'version' ); 12 | 13 | is( $cp->version, '1.2.0', 'chromaprint version is 1.2.0' ); 14 | -------------------------------------------------------------------------------- /chapter_07/chapter_07.pod: -------------------------------------------------------------------------------- 1 | =head1 Proper struct structure 2 | 3 | Before we can begin working with a typemap, we want to have a proper 4 | structure that holds all the relevant information for us. 5 | 6 | If, for example, we want to store the algorithm, it would make more sense 7 | to store it behind the scenes and then present it. If we want to hold on 8 | to the Chromaprint context variable, have it stored in the same structure 9 | with the algorithm make sense. 10 | 11 | Having a proper structure (using a C) allows us to maintain our 12 | own context containing all we need to represent the Chromaprint context, 13 | and to add new abilities that do not exist in the Chromaprint context 14 | without pushing it into the hash - a place that is too visible for the 15 | user and can be changed. 16 | 17 | =head2 The struct 18 | 19 | Let's start by defining our struct: 20 | 21 | typedef struct { 22 | int algorithm; 23 | ChromaprintContext* cp_ctx; 24 | } CTX; 25 | 26 | 27 | This struct, which we named B contains both the algorithm and the 28 | Chromaprint context. 29 | 30 | =head2 Using it 31 | 32 | We can use it in our XS code. First we declare it and allocate enough 33 | memory to store in it: 34 | 35 | PREINIT: 36 | CTX* ctx = (CTX *)malloc( sizeof(CTX) ); 37 | 38 | Now we use it to store both the Chromaprint context and the algorithm: 39 | 40 | ctx->cp_ctx = chromaprint_new(algo); 41 | ctx->algorithm = algo; 42 | 43 | And then we adjust everything that uses it. 44 | 45 | =over 4 46 | 47 | =item * When setting options 48 | 49 | chromaprint_set_option( 50 | ctx->cp_ctx, 51 | s_threshold, 52 | SvIV( *s_threshold_val ) 53 | ); 54 | 55 | =item * When storing a pointer in the hash 56 | 57 | hv_store( 58 | hash, 59 | "_cp_ptr", 60 | strlen("_cp_ptr"), 61 | newSViv( PTR2IV(ctx) ), 62 | FALSE 63 | ); 64 | 65 | =item * Algorithm method 66 | 67 | The algorithm method should now revive the struct using the pointer address 68 | saved in the hash and retrieve the algorithm from that struct: 69 | 70 | ... 71 | svp = hv_fetch(...) 72 | 73 | if ( svp && SvOK(*svp) ) { 74 | ctx = (CTX *) SvIV(*svp); 75 | RETVAL = newSViv( ctx->algorithm ); 76 | } 77 | 78 | OUTPUT: RETVAL 79 | 80 | =item * DESTROY method 81 | 82 | And of course, when freeing the memory, we now have two structs to clear: 83 | 84 | svp = hv_fetchs( hash, "_cp_ptr", FALSE ); 85 | 86 | if ( svp && SvOK(*svp) ) { 87 | ctx = (CTX *) SvIV(*svp); 88 | chromaprint_free( ctx->cp_ctx ); 89 | free(ctx); 90 | } 91 | 92 | =back 93 | -------------------------------------------------------------------------------- /chapter_08/Audio-Chromaprint/Chromaprint.xs: -------------------------------------------------------------------------------- 1 | #define PERL_NO_GET_CONTEXT 2 | #include "EXTERN.h" 3 | #include "perl.h" 4 | #include "XSUB.h" 5 | #include "ppport.h" 6 | 7 | #include 8 | 9 | typedef struct { 10 | int algorithm; 11 | ChromaprintContext* cp_ctx; 12 | } CTX; 13 | 14 | typedef CTX* Audio__Chromaprint; 15 | 16 | MODULE = Audio::Chromaprint PACKAGE = Audio::Chromaprint 17 | 18 | PROTOTYPES: ENABLED 19 | 20 | Audio::Chromaprint 21 | new( const char *class, ... ) 22 | PREINIT: 23 | CTX* ctx = (CTX *)malloc( sizeof(CTX) ); 24 | 25 | CODE: 26 | if ( ( items - 1 ) % 2 ) 27 | croak("Expecting a hash as input to constructor"); 28 | 29 | HV *hash = newHV(); 30 | 31 | int i, algo = CHROMAPRINT_ALGORITHM_DEFAULT; 32 | for ( i = 1; i < items; i += 2 ) { 33 | SV *key = ST(i); 34 | SV *value = newSVsv( ST( i + 1 ) ); 35 | 36 | // we only store unless it's the algorithm 37 | // then we simply override the value and store it later 38 | if ( strcmp( SvPV_nolen( ST(i) ), "algorithm" ) == 0 ) { 39 | const char *algo_v = SvPV_nolen(value); 40 | // check algorithm options 41 | if (!strcmp( algo_v, "test1")) { 42 | algo = CHROMAPRINT_ALGORITHM_TEST1; 43 | } else if (!strcmp(algo_v, "test2")) { 44 | algo = CHROMAPRINT_ALGORITHM_TEST2; 45 | } else if (!strcmp(algo_v, "test3")) { 46 | algo = CHROMAPRINT_ALGORITHM_TEST3; 47 | } else if (!strcmp(algo_v, "test4")) { 48 | algo = CHROMAPRINT_ALGORITHM_TEST4; 49 | } else { 50 | warn("WARNING: unknown algorithm, using the default"); 51 | } 52 | } else { 53 | hv_store_ent( hash, key, value, 0 ); 54 | } 55 | } 56 | 57 | ctx->cp_ctx = chromaprint_new(algo); 58 | ctx->algorithm = algo; 59 | 60 | // set all variables in the chromaprint object 61 | const char *s_threshold = "silence_threshold"; 62 | if ( hv_exists( hash, s_threshold, strlen(s_threshold) ) ) { 63 | SV **s_threshold_val = hv_fetch( hash, s_threshold, strlen(s_threshold), FALSE ); 64 | chromaprint_set_option( 65 | ctx->cp_ctx, 66 | s_threshold, 67 | SvIV( *s_threshold_val ) 68 | ); 69 | } 70 | 71 | RETVAL = ctx; 72 | OUTPUT: RETVAL 73 | 74 | const char * 75 | version(SV *self) 76 | CODE: 77 | RETVAL = chromaprint_get_version(); 78 | OUTPUT: RETVAL 79 | 80 | SV * 81 | algorithm(Audio::Chromaprint self) 82 | CODE: 83 | RETVAL = newSViv( self->algorithm ); 84 | OUTPUT: RETVAL 85 | 86 | void 87 | DESTROY(Audio::Chromaprint self) 88 | CODE: 89 | chromaprint_free( self->cp_ctx ); 90 | Safefree(self); 91 | -------------------------------------------------------------------------------- /chapter_08/Audio-Chromaprint/MANIFEST: -------------------------------------------------------------------------------- 1 | Chromaprint.xs 2 | lib/Audio/Chromaprint.pm 3 | Makefile.PL 4 | MANIFEST This list of files 5 | ppport.h 6 | t/new.t 7 | t/leak.t 8 | t/leak-pointer.t 9 | t/version.t 10 | typemap 11 | -------------------------------------------------------------------------------- /chapter_08/Audio-Chromaprint/Makefile.PL: -------------------------------------------------------------------------------- 1 | use 5.008005; 2 | use ExtUtils::MakeMaker; 3 | WriteMakefile( 4 | NAME => 'Audio::Chromaprint', 5 | VERSION_FROM => 'lib/Audio/Chromaprint.pm', 6 | PREREQ_PM => { 'Test::More' => 0 }, 7 | ABSTRACT_FROM => 'lib/Audio/Chromaprint.pm', 8 | AUTHOR => 'You', 9 | LIBS => ['-lchromaprint'], 10 | DEFINE => '', 11 | INC => '-I.', 12 | OBJECT => '$(O_FILES)', 13 | ); 14 | 15 | -------------------------------------------------------------------------------- /chapter_08/Audio-Chromaprint/lib/Audio/Chromaprint.pm: -------------------------------------------------------------------------------- 1 | package Audio::Chromaprint; 2 | 3 | use strict; 4 | use warnings; 5 | use XSLoader; 6 | 7 | our $VERSION = '0.001'; 8 | 9 | XSLoader::load( 'Audio::Chromaprint', $VERSION ); 10 | 11 | 1; 12 | 13 | __END__ 14 | 15 | =head1 NAME 16 | 17 | Audio::Chromaprint - Interface to the Chromaprint library 18 | 19 | -------------------------------------------------------------------------------- /chapter_08/Audio-Chromaprint/t/leak-pointer.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 2; 6 | use Test::MemoryGrowth; 7 | 8 | use_ok( 'Audio::Chromaprint' ); 9 | 10 | no_growth { Audio::Chromaprint->new; } 11 | calls => 100, 12 | burn_in => 100, 13 | 'Does not grow in memory'; 14 | -------------------------------------------------------------------------------- /chapter_08/Audio-Chromaprint/t/leak.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 2; 6 | 7 | use_ok( 'Audio::Chromaprint' ); 8 | 9 | my $called = 0; 10 | { 11 | no warnings qw; 12 | *Audio::Chromaprint::DESTROY = sub ($) { 13 | $called++; 14 | }; 15 | } 16 | 17 | { 18 | my $cp = Audio::Chromaprint->new; 19 | } 20 | 21 | cmp_ok( $called, '==', 1, 'Destruction successful' ); 22 | -------------------------------------------------------------------------------- /chapter_08/Audio-Chromaprint/t/new.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 10; 6 | use Test::Fatal; 7 | 8 | use_ok( 'Audio::Chromaprint' ); 9 | 10 | { 11 | like( 12 | exception { Audio::Chromaprint->new('SingleInput') }, 13 | qr/^Expecting a hash as input to constructor/, 14 | 'Incorrect input for single item (instead of pairs)', 15 | ); 16 | 17 | like( 18 | exception { Audio::Chromaprint->new( 1, 2, 3 ) }, 19 | qr/^Expecting a hash as input to constructor/, 20 | 'Incorrect input for odd items (instead of pairs)', 21 | ); 22 | 23 | is( 24 | exception { Audio::Chromaprint->new() }, 25 | undef, 26 | 'Successful at calling a constructor without arguments', 27 | ); 28 | 29 | is( 30 | exception { Audio::Chromaprint->new( key => 'value' ) }, 31 | undef, 32 | 'Successful at calling a constructor with even items', 33 | ); 34 | } 35 | 36 | { 37 | my $cp = Audio::Chromaprint->new(); 38 | 39 | isa_ok( $cp, 'Audio::Chromaprint' ); 40 | can_ok( $cp, 'algorithm' ); 41 | 42 | is( 43 | $cp->algorithm, 44 | 1, 45 | 'Constructor set correct default algorithm', 46 | ); 47 | } 48 | 49 | { 50 | my $cp = Audio::Chromaprint->new( 51 | algorithm => 'test3', 52 | ); 53 | 54 | isa_ok( $cp, 'Audio::Chromaprint' ); 55 | is( 56 | $cp->algorithm, 57 | 2, 58 | 'Constructor set correct algorithm from argument', 59 | ); 60 | } 61 | -------------------------------------------------------------------------------- /chapter_08/Audio-Chromaprint/t/version.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings; 4 | 5 | use Test::More tests => 4; 6 | 7 | use_ok( 'Audio::Chromaprint' ); 8 | 9 | my $cp = Audio::Chromaprint->new(); 10 | isa_ok( $cp, 'Audio::Chromaprint' ); 11 | can_ok( $cp, 'version' ); 12 | 13 | is( $cp->version, '1.2.0', 'chromaprint version is 1.2.0' ); 14 | -------------------------------------------------------------------------------- /chapter_08/Audio-Chromaprint/typemap: -------------------------------------------------------------------------------- 1 | Audio::Chromaprint T_PTROBJ 2 | -------------------------------------------------------------------------------- /chapter_08/chapter_08.pod: -------------------------------------------------------------------------------- 1 | =head1 Mapping types 2 | 3 | XSUBs (XS functions) receive and return Perl's C data types: B, 4 | B, B, and so forth. If we want to return an B, we will need 5 | to create an B with the value and return it. If we want to receive an 6 | B we will need to translate an B back to an B. 7 | 8 | These translations are very common and because of it, Perl's XS layer 9 | has a mechanism especially for that. In fact, it uses that mechanism to 10 | allow you to specify more specific types of B (such as B or B) 11 | in function declarations. 12 | 13 | Perl's XS translation mechanism provides a comfortable way to indicate how to 14 | translate these types (and any others you want) and have Perl's XS 15 | preprocessor add the translation code for you. Bs are the mechanism 16 | XS uses to automatically translate between different data types. 17 | 18 | You can create your own or use the default ones that Perl provides out 19 | of the box. In fact, we're using those already in our code. 20 | 21 | You can read about typemaps in 22 | L. 23 | 24 | We will use a typemap to convert our context structure to a Perl variable 25 | and back. 26 | 27 | =head2 Basic structs 28 | 29 | Once we have a struct, Perl has a basic typemap for translating a struct 30 | into a reference. This will allow us to automatically receive a reference 31 | from C when C's XS code simply returns a pointer to our new 32 | struct. 33 | 34 | There is one big caveat, as we will see. 35 | 36 | =head2 The typemap file 37 | 38 | First, we create a F file. Perl has a default type called 39 | B. The documentation is as follows: 40 | 41 | The pointer is blessed into a class that is derived from the name 42 | of type of the pointer but with all '*' in the name replaced with 43 | 'Ptr'. 44 | 45 | This means that we need to provide B with a package name. If we 46 | had any asterisks in the typemap definition, it would replace the asterisks 47 | with the string C. Hence if we had the line: 48 | 49 | SomeClass * T_PTROBJ 50 | 51 | it will bless the pointer to the package C. 52 | 53 | Now we need to adjust the XS layer. The tests will be the really awkward 54 | part. 55 | 56 | =head2 Adjust the XS part 57 | 58 | In order to return the context struct, we need to delete the code that 59 | creates the hash reference we have (you might begin to see the caveat), 60 | so we delete the following chunks of code: 61 | 62 | // store the pointer to the chromaprint object in the hash 63 | // user plays with it, it breaks 64 | hv_store( 65 | hash, 66 | "_cp_ptr", 67 | strlen("_cp_ptr"), 68 | newSViv( PTR2IV(ctx) ), 69 | FALSE 70 | ); 71 | 72 | SV* const self = newRV_noinc( (SV *)hash ); 73 | 74 | RETVAL = sv_bless( self, gv_stashpv( class, 0 ) ); 75 | 76 | Instead, we change the C to just return the context: 77 | 78 | RETVAL = ctx; 79 | 80 | We also need to make sure we return an C variable. 81 | We change the beginning of the XS function to: 82 | 83 | Audio::Chromaprint 84 | new( const char *class, ... ) 85 | 86 | Perl will do something quite interesting here. Let's print out what we 87 | get back using L: 88 | 89 | SV = IV(0xd0f640) at 0xd0f650 90 | REFCNT = 1 91 | FLAGS = (PADMY,ROK) 92 | RV = 0xc3b0f8 93 | SV = PVMG(0xde75d0) at 0xc3b0f8 94 | REFCNT = 1 95 | FLAGS = (OBJECT,IOK,pIOK) 96 | IV = 14770176 97 | NV = 0 98 | PV = 0 99 | STASH = 0xe3b368 "Audio::Chromaprint" 100 | 101 | I<(This might look a bit different, depending upon your version of the Perl 102 | interpreter.)> 103 | 104 | We have an B which is an B, which references a B, which has 105 | an B slot with a value, and a B defined with the package. 106 | 107 | Translating this to Perl, we end up with a scalar reference, blessed into 108 | the B package. The scalar value is the pointer address 109 | for our C-level C struct pointer. 110 | 111 | Now we see the full caveat: We don't have a hash reference back, we only 112 | have a scalar reference back. Moreover, we have the pointer address as a 113 | value of the scalar, which means someone can change it if they want. 114 | 115 | =head2 Testing 116 | 117 | If we try our memory leak test right now, it will not work as expected. 118 | The typemap blesses into the package C, while our 119 | test has an object based on it instead. This means that our C 120 | method will not be called - only the C of C. 121 | 122 | A way to fix it is to override the original method in the right package, 123 | and use that to increment the counter, to know that it was called. 124 | 125 | The following should be our test: 126 | 127 | my $called = 0; 128 | { 129 | no warnings qw; 130 | *Audio::Chromaprint::DESTROY = sub ($) { 131 | $called++; 132 | my $self = shift; 133 | }; 134 | } 135 | 136 | { 137 | my $cp = Audio::Chromaprint->new; 138 | } 139 | 140 | You will notice we have a prototype on the C method - that is 141 | because the XS version has a prototype too. 142 | -------------------------------------------------------------------------------- /skeleton/Audio-Chromaprint/Chromaprint.xs: -------------------------------------------------------------------------------- 1 | #define PERL_NO_GET_CONTEXT 2 | #include "EXTERN.h" 3 | #include "perl.h" 4 | #include "XSUB.h" 5 | #include "ppport.h" 6 | 7 | #include 8 | 9 | /* C functions */ 10 | 11 | MODULE = Audio::Chromaprint PACKAGE = Audio::Chromaprint 12 | 13 | # XS code 14 | 15 | PROTOTYPES: ENABLED 16 | 17 | SV * 18 | new( const char *class ) 19 | CODE: 20 | /* Create a hash */ 21 | HV* hash = newHV(); 22 | 23 | /* Create a reference to the hash */ 24 | SV *const self = newRV_inc( (SV *)hash ); 25 | 26 | /* bless into the proper package */ 27 | RETVAL = sv_bless( self, gv_stashpv( class, 0 ) ); 28 | OUTPUT: RETVAL 29 | 30 | -------------------------------------------------------------------------------- /skeleton/Audio-Chromaprint/MANIFEST: -------------------------------------------------------------------------------- 1 | Chromaprint.xs 2 | lib/Audio/Chromaprint.pm 3 | Makefile.PL 4 | MANIFEST This list of files 5 | ppport.h 6 | t/version.t 7 | -------------------------------------------------------------------------------- /skeleton/Audio-Chromaprint/Makefile.PL: -------------------------------------------------------------------------------- 1 | use 5.006000; 2 | use ExtUtils::MakeMaker; 3 | WriteMakefile( 4 | NAME => 'Audio::Chromaprint', 5 | VERSION_FROM => 'lib/Audio/Chromaprint.pm', 6 | PREREQ_PM => { 'Test::More' => 0 }, 7 | ABSTRACT_FROM => 'lib/Audio/Chromaprint.pm', 8 | AUTHOR => 'You', 9 | LIBS => ['-lchromaprint'], 10 | DEFINE => '', # e.g., '-DHAVE_SOMETHING' 11 | INC => '-I.', # e.g., '-I. -I/usr/include/other' 12 | OBJECT => '$(O_FILES)', # link all the C files too 13 | LICENSE => 'perl', # or your choice 14 | META_MERGE => { 15 | resources => { 16 | repository => { 17 | type => 'git', 18 | url => 'git@github.com:your-github-username/p5-Audio-Chromaprint.git', 19 | web => 'https://github.com/your-github-username/p5-Audio-Chromaprint', 20 | }, 21 | }, 22 | 'meta-spec' => { version => 2 }, 23 | }, 24 | ); 25 | -------------------------------------------------------------------------------- /skeleton/Audio-Chromaprint/lib/Audio/Chromaprint.pm: -------------------------------------------------------------------------------- 1 | package Audio::Chromaprint; 2 | 3 | use strict; 4 | use warnings; 5 | use XSLoader; 6 | 7 | our $VERSION = '0.001'; 8 | 9 | XSLoader::load( 'Audio::Chromaprint', $VERSION ); 10 | 11 | 1; 12 | 13 | __END__ 14 | 15 | =head1 NAME 16 | 17 | Audio::Chromaprint - Interface to the Chromaprint library 18 | 19 | -------------------------------------------------------------------------------- /skeleton/XSFun/Makefile.PL: -------------------------------------------------------------------------------- 1 | use 5.006000; 2 | use ExtUtils::MakeMaker; 3 | WriteMakefile( 4 | NAME => 'XSFun', 5 | VERSION_FROM => 'lib/XSFun.pm', 6 | PREREQ_PM => { 'Test::More' => 0, 'Exporter' => '5.57' }, 7 | ABSTRACT_FROM => 'lib/XSFun.pm', 8 | AUTHOR => 'You', 9 | LIBS => [''], # e.g., '-lm' 10 | DEFINE => '', # e.g., '-DHAVE_SOMETHING' 11 | INC => '-I.', # e.g., '-I. -I/usr/include/other' 12 | OBJECT => '$(O_FILES)', # link all the C files too 13 | LICENSE => 'perl', # or your choice 14 | META_MERGE => { 15 | resources => { 16 | repository => { 17 | type => 'git', 18 | url => 'git@github.com:your-github-username/p5-XSFun.git', 19 | web => 'https://github.com/your-github-username/p5-XSFun', 20 | }, 21 | }, 22 | 'meta-spec' => { version => 2 }, 23 | }, 24 | ); 25 | -------------------------------------------------------------------------------- /skeleton/XSFun/XSFun.xs: -------------------------------------------------------------------------------- 1 | #define PERL_NO_GET_CONTEXT 2 | #include "EXTERN.h" 3 | #include "perl.h" 4 | #include "XSUB.h" 5 | #include "ppport.h" 6 | 7 | /* C functions */ 8 | 9 | MODULE = XSFun PACKAGE = XSFun 10 | 11 | # XS code 12 | 13 | -------------------------------------------------------------------------------- /skeleton/XSFun/lib/XSFun.pm: -------------------------------------------------------------------------------- 1 | package XSFun; 2 | 3 | use strict; 4 | use warnings; 5 | use XSLoader; 6 | 7 | use Exporter 5.57 'import'; 8 | 9 | our $VERSION = '0.001'; 10 | our %EXPORT_TAGS = ( 'all' => [] ); 11 | our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); 12 | 13 | XSLoader::load('XSFun', $VERSION); 14 | 15 | 1; 16 | 17 | -------------------------------------------------------------------------------- /skeleton/XSFun/t/XSFun.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings; 4 | 5 | use Test::More tests => 2; 6 | 7 | use_ok('XSFun', ':all'); 8 | 9 | ok( 0, 'Write some tests' ); 10 | -------------------------------------------------------------------------------- /t/chapter_xs.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use warnings; 4 | use strict; 5 | 6 | use Test::More tests => 24; 7 | 8 | use FindBin qw($Bin); 9 | use File::Spec::Functions; 10 | 11 | my $base_dir = catfile($Bin, ".."); 12 | 13 | my %chapter_xs_libs = ( 14 | "chapter_01" => "XSFun", 15 | "chapter_02" => "XSFun", 16 | "chapter_03" => "Audio-Chromaprint", 17 | "chapter_04" => "Audio-Chromaprint", 18 | "chapter_05" => "Audio-Chromaprint", 19 | "chapter_06" => "Audio-Chromaprint", 20 | "chapter_07" => "Audio-Chromaprint", 21 | "chapter_08" => "Audio-Chromaprint", 22 | ); 23 | 24 | my @chapters = sort keys %chapter_xs_libs; 25 | for my $chapter_name (@chapters) { 26 | chdir $base_dir; 27 | my $xs_lib_name = $chapter_xs_libs{$chapter_name}; 28 | my $xs_lib_path = catdir($base_dir, $chapter_name, $xs_lib_name); 29 | chdir $xs_lib_path; 30 | 31 | if (-e "Makefile") { 32 | system("make veryclean"); 33 | } 34 | is(system("perl Makefile.PL"), 0, "Makefile builds successfully"); 35 | is(system("make"), 0, "make runs"); 36 | is(system("make test"), 0, "$xs_lib_name lib tests ok"); 37 | } 38 | 39 | # vim: expandtab shiftwidth=4 40 | -------------------------------------------------------------------------------- /t/pod.t: -------------------------------------------------------------------------------- 1 | use warnings; 2 | use strict; 3 | 4 | use Test::More; 5 | use File::Spec::Functions qw( catfile ); 6 | use Pod::Checker; 7 | 8 | eval { use Test::Pod 1.00 }; 9 | plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; 10 | 11 | my $glob_path = catfile( 'chapter_??', 'chapter_??.pod' ); 12 | my @poddirs = glob $glob_path; 13 | my @pod_files = all_pod_files(@poddirs); 14 | 15 | plan tests => @pod_files * 2; 16 | my $checker = Pod::Checker->new(); 17 | for my $pod_file ( @pod_files ) { 18 | $checker->parse_from_file($pod_file); 19 | is $checker->num_warnings, 0, "Warnings in $pod_file"; 20 | is $checker->num_errors, 0, "Errors in $pod_file"; 21 | 22 | # reset the warnings/errors counter ready to test next file 23 | $checker->num_warnings(0); 24 | $checker->num_errors(0); 25 | } 26 | 27 | # vim: expandtab shiftwidth=4 28 | --------------------------------------------------------------------------------