File Coverage

blib/lib/Module/Starter/XSimple.pm
Criterion Covered Total %
statement 21 107 19.6
branch 0 10 0.0
condition n/a
subroutine 7 18 38.8
pod 8 8 100.0
total 36 143 25.1


line stmt bran cond sub pod time code
1             package Module::Starter::XSimple;
2 1     1   45704 use base 'Module::Starter::Simple';
  1         2  
  1         1323  
3             # vi:et:sw=4 ts=4
4              
5 1     1   28354 use version; $VERSION = qv(v0.0.2);
  1         2491  
  1         9  
6              
7 1     1   92 use warnings;
  1         9  
  1         35  
8 1     1   5 use strict;
  1         1  
  1         27  
9 1     1   7 use Carp;
  1         1  
  1         94  
10 1     1   1125 use Path::Class;
  1         66329  
  1         1183  
11              
12             # Other recommended modules (uncomment to use):
13             # use IO::Prompt;
14             # use Perl6::Export;
15             # use Perl6::Slurp;
16             # use Perl6::Say;
17             # use Regexp::Autoflags;
18              
19              
20             # Module implementation here
21             sub rtname {
22 0     0 1   my ($self, $module) = @_;
23 0           my $rtname = lc $module;
24 0           $rtname =~ s/::/-/g;
25 0           return $rtname;
26             }
27              
28             sub module_path_create {
29 0     0 1   my ($self, $module, $ext) = @_;
30 0 0         $ext = '.pm' unless defined $ext;
31              
32 0           my @parts = split( /::/, $module );
33 0           my $filepart = (pop @parts) . $ext;
34 0           my @dirparts = ( $self->{basedir}, 'lib', @parts );
35 0           my $manifest_file = join( "/", "lib", @parts, $filepart );
36 0 0         if ( @dirparts ) {
37 0           my $dir = File::Spec->catdir( @dirparts );
38 0 0         if ( not -d $dir ) {
39 0           mkpath $dir;
40 0           $self->progress( "Created $dir" );
41             }
42             }
43              
44 0           my $module_file = File::Spec->catfile( @dirparts, $filepart );
45              
46 0           return ($manifest_file, $module_file);
47             }
48              
49              
50             sub create_modules {
51 0     0 1   my $self = shift;
52 0           my @modules = @_;
53              
54 0           my (@files, @xsfile);
55              
56 0           for my $module ( @modules ) {
57 0           push @files, $self->_create_module( $module );
58 0           push @files, $self->_create_xsmodule( $module );
59 0           push @files, $self->_create_typemap( $module );
60             }
61 0           push @files, $self->_create_ppport();
62 0           $self->{xsfiles} =
63              
64             return @files;
65             }
66              
67             sub _create_xsmodule {
68 0     0     my $self = shift;
69 0           my $module = shift;
70              
71 0           my ($manifest_file, $module_file) =
72             $self->module_path_create($module, '.xs');
73 0 0         open( my $fh, ">", $module_file ) or die "Can't create $module_file: $!\n";
74 0           print $fh $self->xsmodule_guts( $module );
75 0           close $fh;
76 0           $self->progress( "Created $module" );
77              
78 0           return $manifest_file;
79             }
80              
81             sub xsmodule_guts {
82 0     0 1   my $self = shift;
83 0           my $module = shift;
84 0           (my $module_obj = $module) =~ s/::/_/g;
85              
86 0           my $year = $self->_thisyear();
87              
88 0           my $content = <<"HERE";
89             #include "EXTERN.h"
90             #include "perl.h"
91             #include "XSUB.h"
92              
93             #include "ppport.h"
94              
95             typedef SV * $module_obj;
96              
97             MODULE = $module PACKAGE = $module
98              
99             $module_obj
100             new(...)
101             INIT:
102             char *classname;
103             /* get the class name if called as an object method */
104             if ( sv_isobject(ST(0)) ) {
105             classname = HvNAME(SvSTASH(SvRV(ST(0))));
106             }
107             else {
108             classname = (char *)SvPV_nolen(ST(0));
109             }
110              
111             CODE:
112             /* This is a standard hash-based object */
113             RETVAL = ($module_obj)newHV();
114              
115             /* Single init value */
116             if ( items == 2 )
117             hv_store((HV *)RETVAL, "value", 5, newSVsv(ST(1)), 0);
118             /* name/value pairs */
119             else if ( (items-1)%2 == 0 ) {
120             int i;
121             for ( i=1; i < items; i += 2 ) {
122             hv_store_ent((HV *)RETVAL, ST(i), newSVsv(ST(i+1)), 0);
123             }
124             }
125             /* odd number of parameters */
126             else {
127             Perl_croak(aTHX_
128             "Usage: $module->new()\\n"
129             " or $module->new(number)\\n"
130             " or $module->new(key => value, ...)\\n"
131             );
132             }
133              
134             OUTPUT:
135             RETVAL
136              
137             IV
138             increment(obj)
139             $module_obj obj
140              
141             INIT:
142             RETVAL = 0;
143             if ( items > 1 )
144             Perl_croak(aTHX_ "Usage: $module->increment()");
145              
146             CODE:
147             SV **svp;
148             if ((svp = hv_fetch((HV*)obj, "value", 5, FALSE))) {
149             RETVAL = SvIV(*svp);
150             RETVAL++;
151             hv_store((HV *)obj, "value", 5, newSViv(RETVAL), 0);
152             }
153             OUTPUT:
154             RETVAL
155             HERE
156              
157 0           return $content;
158             }
159              
160             sub _create_typemap {
161 0     0     my $self = shift;
162 0           my $module = shift;
163              
164 0           my ($manifest_file, $typemap_file) =
165             $self->module_path_create($module, '');
166            
167             #change typemap file name to 'typemap'
168 0           $manifest_file = Path::Class::File->new($manifest_file)->parent->file('typemap');
169 0           $typemap_file = Path::Class::File->new($typemap_file)->parent->file('typemap');
170              
171 0 0         open( my $fh, ">", $typemap_file )
172             or die "Can't create $typemap_file: $!\n";
173 0           print "open $typemap_file to print typemap to\n";
174 0           print $fh $self->typemap_guts($module);
175 0           close $fh;
176 0           $self->progress( "Created typemap" );
177              
178 0           return $manifest_file;
179             }
180              
181             sub typemap_guts {
182 0     0 1   my $self = shift;
183 0           my $module = shift;
184 0           (my $module_obj = $module) =~ s/::/_/g;
185              
186 0           my $year = $self->_thisyear();
187 0           my $author = $self->{author};
188              
189             # First the portion that needs substitution
190 0           my $content = qq(\
191             ###############################################################################
192             ##
193             ## Typemap for $module objects
194             ##
195             ## Copyright (c) $year $author
196             ## All rights reserved.
197             ##
198             ## This typemap is designed specifically to make it easier to handle
199             ## Perl-style blessed objects in XS. In particular, it takes care of
200             ## blessing the object into the correct class (even for derived classes).
201             ##
202             ##
203             ###############################################################################
204             ## vi:et:sw=4 ts=4
205              
206             TYPEMAP
207              
208             $module_obj T_PTROBJ_SPECIAL
209             );
210             # And the the portion that must be literal
211 0           $content .= q(
212             INPUT
213             T_PTROBJ_SPECIAL
214             if (sv_derived_from($arg, \"${(my $ntt=$ntype)=~s/_/::/g;\$ntt}\")) {
215             $var = SvRV($arg);
216             }
217             else
218             croak(\"$var is not of type ${(my $ntt=$ntype)=~s/_/::/g;\$ntt}\")
219              
220             OUTPUT
221             T_PTROBJ_SPECIAL
222             /* inherited new() */
223             if ( strcmp(classname,\"${(my $ntt=$ntype)=~s/_/::/g;\$ntt}\") != 0 )
224             $arg = sv_bless(newRV_noinc($var),
225             gv_stashpv(classname,TRUE));
226             else
227             $arg = sv_bless(newRV_noinc($var),
228             gv_stashpv(\"${(my $ntt=$ntype)=~s/_/::/g;\$ntt}\",TRUE));
229             );
230 0           return $content;
231             }
232              
233             sub _create_ppport {
234 1     1   114808 use Devel::PPPort;
  1         681  
  1         1036  
235 0     0     my $self = shift;
236              
237 0           my $ppport_file = File::Spec->catfile( $self->{basedir}, "ppport.h" );
238 0           Devel::PPPort::WriteFile($ppport_file);
239 0           $self->progress( "Created ppport" );
240              
241 0           return "ppport.h";
242             }
243              
244             sub Build_PL_guts {
245 0     0 1   my $self = shift;
246 0           my $main_module = shift;
247 0           my $main_pm_file = shift;
248 0           my $xsmodule = ( split (/::/, $main_module) )[-1];
249 0           (my $xsmodule_path = $main_pm_file) =~ s/\.pm$/.xs/;
250              
251 0           (my $author = "$self->{author} <$self->{email}>") =~ s/'/\'/g;
252              
253 0           return <<"HERE";
254             use strict;
255             use warnings;
256             use Module::Build;
257              
258             my \$builder = Module::Build->new(
259             module_name => '$main_module',
260             license => '$self->{license}',
261             dist_author => '$author',
262             dist_version_from => '$main_pm_file',
263             include_dirs => ['.'],
264             requires => {
265             'Test::More' => 0,
266             },
267             add_to_cleanup => [ '$self->{distro}-*' ],
268             );
269              
270             \$builder->create_build_script();
271             HERE
272             }
273              
274             sub module_guts {
275 0     0 1   my $self = shift;
276 0           my $module = shift;
277              
278 0           my $year = $self->_thisyear();
279 0           my $rtname = $self->rtname($module);
280              
281 0           my $content = <<"HERE";
282             package $module;
283              
284             use warnings;
285             use strict;
286              
287             \=head1 NAME
288              
289             $module - The great new $module!
290              
291             \=head1 VERSION
292              
293             Version 0.01
294              
295             \=cut
296              
297             our \$VERSION = '0.01';
298              
299             require XSLoader;
300             XSLoader::load('$module', \$VERSION);
301              
302             \=head1 SYNOPSIS
303              
304             Quick summary of what the module does.
305              
306             Perhaps a little code snippet.
307              
308             use $module;
309              
310             my \$foo = $module->new();
311             ...
312              
313             \=head1 EXPORT
314              
315             A list of functions that can be exported. You can delete this section
316             if you don't export anything, such as for a purely object-oriented module.
317              
318             \=head1 FUNCTIONS
319              
320             \=head2 new
321              
322             Creates a new $module object. Takes the following optional parameters:
323              
324             \=over 4
325              
326             \=item value
327              
328             If you pass a single numeric value, it will be stored in the 'value' slot
329             of the object hash.
330              
331             \=item key/value pair
332              
333             A generic input method which takes an unlimited number of key/value pairs
334             and stores them in the object hash. Performs no validation.
335              
336             \=back
337              
338             \=cut
339              
340             #sub new {
341             # Defined in the XS code
342             #}
343              
344             \=head2 increment
345              
346             An object method which increments the 'value' slot of the the object hash,
347             if it exists. Called like this:
348              
349             my \$obj = $module->new(5);
350             \$obj->increment(); # now equal to 6
351              
352             \=cut
353              
354             #sub function2 {
355             # Defined in the XS code
356             #}
357              
358             \=head1 AUTHOR
359              
360             $self->{author}, C<< <$self->{email}> >>
361              
362             \=head1 BUGS
363              
364             Please report any bugs or feature requests to
365             C, or through the web interface at
366             L{distro}>.
367             I will be notified, and then you'll automatically be notified of progress on
368             your bug as I make changes.
369              
370             \=head1 ACKNOWLEDGEMENTS
371              
372             \=head1 COPYRIGHT & LICENSE
373              
374             Copyright $year $self->{author}, All Rights Reserved.
375              
376             This program is free software; you can redistribute it and/or modify it
377             under the same terms as Perl itself.
378              
379             \=cut
380              
381             1; # End of $module
382             HERE
383 0           return $content;
384             }
385              
386             sub t_guts {
387 0     0 1   my $self = shift;
388 0           my @modules = @_;
389 0           my %t_files = $self->SUPER::t_guts(@modules);
390 0           my $main_module = $modules[0];
391 0           my $use_lines = join( "\n", map { "use_ok( '$_' );" } @modules );
  0            
392              
393 0           $t_files{'01-object.t'} = <<"HERE";
394              
395             use Test::More tests => 10;
396              
397             BEGIN {
398             $use_lines
399             }
400              
401             my \$obj;
402              
403             ok( \$obj = ${main_module}->new(), "no initializer");
404             isa_ok(\$obj,"${main_module}");
405              
406             ok( \$obj = ${main_module}->new(1), "initial numeric value");
407             ok(\$obj->{value} == 1, "implicit initializer");
408              
409             ok( \$obj = ${main_module}->new("fish"), "initial string value");
410             ok(\$obj->{value} eq "fish", "implicit initializer");
411              
412             ok( \$obj = ${main_module}->new(color => "red", flavor => "sour"),
413             "hash as initializer");
414             ok( \$obj->{color} eq "red", "first hash key");
415             ok( \$obj->{flavor} eq "sour", "first hash key");
416             HERE
417              
418 0           $t_files{'02-feature.t'} = <<"HERE";
419             use Test::More tests => 5;
420              
421             BEGIN {
422             $use_lines
423             }
424              
425             my \$obj = ${main_module}->new(1);
426             ok( \$obj->increment );
427             ok( \$obj->{value} == 2);
428              
429             \$obj = ${main_module}->new(value => 3);
430             ok( \$obj->{value} == 3 );
431             ok( \$obj->increment == 4 );
432             HERE
433              
434 0           return %t_files;
435             }
436            
437             1; # Magic true value required at end of module
438             __END__