line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
=head1 NAME |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
PDL::Core::Dev - PDL development module |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
=head1 DESCRIPTION |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
This module encapsulates most of the stuff useful for |
8
|
|
|
|
|
|
|
PDL development and is often used from within Makefile.PL's. |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
=head1 SYNOPSIS |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
use PDL::Core::Dev; |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
=head1 FUNCTIONS |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
=cut |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
# Stuff used in development/install environment of PDL Makefile.PL's |
19
|
|
|
|
|
|
|
# - not part of PDL itself. |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
package PDL::Core::Dev; |
22
|
|
|
|
|
|
|
|
23
|
6
|
|
|
6
|
|
544
|
use File::Path; |
|
6
|
|
|
|
|
21
|
|
|
6
|
|
|
|
|
695
|
|
24
|
6
|
|
|
6
|
|
48
|
use File::Basename; |
|
6
|
|
|
|
|
19
|
|
|
6
|
|
|
|
|
811
|
|
25
|
6
|
|
|
6
|
|
3600
|
use ExtUtils::Manifest; |
|
6
|
|
|
|
|
55363
|
|
|
6
|
|
|
|
|
370
|
|
26
|
6
|
|
|
6
|
|
3341
|
use English; require Exporter; |
|
6
|
|
|
|
|
12969
|
|
|
6
|
|
|
|
|
65
|
|
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
@ISA = qw( Exporter ); |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
@EXPORT = qw( isbigendian genpp %PDL_DATATYPES |
31
|
|
|
|
|
|
|
PDL_INCLUDE PDL_TYPEMAP |
32
|
|
|
|
|
|
|
PDL_AUTO_INCLUDE PDL_BOOT |
33
|
|
|
|
|
|
|
PDL_INST_INCLUDE PDL_INST_TYPEMAP |
34
|
|
|
|
|
|
|
pdlpp_postamble_int pdlpp_stdargs_int |
35
|
|
|
|
|
|
|
pdlpp_postamble pdlpp_stdargs write_dummy_make |
36
|
|
|
|
|
|
|
unsupported getcyglib trylink |
37
|
|
|
|
|
|
|
pdlpp_mkgen |
38
|
|
|
|
|
|
|
); |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
# Installation locations |
41
|
|
|
|
|
|
|
# beware: whereami_any now appends the /Basic or /PDL directory as appropriate |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
# The INST are here still just in case we want to change something later. |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
# print STDERR "executing PDL::Core::Dev from",join(',',caller),"\n"; |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
# Return library locations |
48
|
|
|
|
|
|
|
|
49
|
5
|
|
|
5
|
0
|
278
|
sub PDL_INCLUDE { '"-I'.whereami_any().'/Core"' }; |
50
|
4
|
|
|
4
|
0
|
11
|
sub PDL_TYPEMAP { whereami_any().'/Core/typemap.pdl' }; |
51
|
|
|
|
|
|
|
# sub PDL_INST_INCLUDE { '-I'.whereami_any().'/Core' }; |
52
|
|
|
|
|
|
|
# sub PDL_INST_TYPEMAP { whereami_any().'/Core/typemap.pdl' }; |
53
|
|
|
|
|
|
|
|
54
|
2
|
|
|
2
|
0
|
8
|
sub PDL_INST_INCLUDE {&PDL_INCLUDE} |
55
|
2
|
|
|
2
|
0
|
7
|
sub PDL_INST_TYPEMAP {&PDL_TYPEMAP} |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
sub PDL_AUTO_INCLUDE { |
58
|
1
|
|
|
1
|
0
|
3
|
my ($symname) = @_; |
59
|
1
|
|
50
|
|
|
3
|
$symname ||= 'PDL'; |
60
|
1
|
|
|
|
|
4
|
return << "EOR"; |
61
|
|
|
|
|
|
|
#include |
62
|
|
|
|
|
|
|
static Core* $symname; /* Structure holds core C functions */ |
63
|
|
|
|
|
|
|
static SV* CoreSV; /* Gets pointer to perl var holding core structure */ |
64
|
|
|
|
|
|
|
EOR |
65
|
|
|
|
|
|
|
} |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
sub PDL_BOOT { |
68
|
2
|
|
|
2
|
0
|
7
|
my ($symname, $module) = @_; |
69
|
2
|
|
50
|
|
|
7
|
$symname ||= 'PDL'; |
70
|
2
|
|
50
|
|
|
6
|
$module ||= 'The code'; |
71
|
2
|
|
|
|
|
19
|
return << "EOR"; |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
perl_require_pv ("PDL/Core.pm"); /* make sure PDL::Core is loaded */ |
74
|
|
|
|
|
|
|
#ifndef aTHX_ |
75
|
|
|
|
|
|
|
#define aTHX_ |
76
|
|
|
|
|
|
|
#endif |
77
|
|
|
|
|
|
|
if (SvTRUE (ERRSV)) Perl_croak(aTHX_ "%s",SvPV_nolen (ERRSV)); |
78
|
|
|
|
|
|
|
CoreSV = perl_get_sv("PDL::SHARE",FALSE); /* SV* value */ |
79
|
|
|
|
|
|
|
if (CoreSV==NULL) |
80
|
|
|
|
|
|
|
Perl_croak(aTHX_ "We require the PDL::Core module, which was not found"); |
81
|
|
|
|
|
|
|
$symname = INT2PTR(Core*,SvIV( CoreSV )); /* Core* value */ |
82
|
|
|
|
|
|
|
if ($symname->Version != PDL_CORE_VERSION) |
83
|
|
|
|
|
|
|
Perl_croak(aTHX_ "[$symname->Version: \%d PDL_CORE_VERSION: \%d XS_VERSION: \%s] $module needs to be recompiled against the newly installed PDL", $symname->Version, PDL_CORE_VERSION, XS_VERSION); |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
EOR |
86
|
|
|
|
|
|
|
} |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
# whereami_any returns appended 'Basic' or 'PDL' dir as appropriate |
89
|
6
|
|
|
6
|
|
4653
|
use Cwd qw/abs_path/; |
|
6
|
|
|
|
|
19
|
|
|
6
|
|
|
|
|
4270
|
|
90
|
|
|
|
|
|
|
sub whereami_any { |
91
|
13
|
|
50
|
13
|
0
|
33
|
my $dir = (&whereami(1) or &whereami_inst(1) or |
92
|
|
|
|
|
|
|
die "Unable to determine ANY directory path to PDL::Core::Dev module\n"); |
93
|
13
|
|
|
|
|
571
|
return abs_path($dir); |
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
sub whereami { |
97
|
16
|
|
|
16
|
0
|
61
|
for $dir (@INC,qw|. .. ../.. ../../.. ../../../..|) { |
98
|
186
|
50
|
|
|
|
2465
|
return ($_[0] ? $dir . '/Basic' : $dir) |
|
|
100
|
|
|
|
|
|
99
|
|
|
|
|
|
|
if -e "$dir/Basic/Core/Dev.pm"; |
100
|
|
|
|
|
|
|
} |
101
|
0
|
0
|
|
|
|
0
|
die "Unable to determine UNINSTALLED directory path to PDL::Core::Dev module\n" |
102
|
|
|
|
|
|
|
if !$_[0]; |
103
|
0
|
|
|
|
|
0
|
return undef; |
104
|
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
sub whereami_inst { |
107
|
0
|
|
|
0
|
0
|
0
|
for $dir (@INC,map {$_."/blib"} qw|. .. ../.. ../../.. ../../../..|) { |
|
0
|
|
|
|
|
0
|
|
108
|
0
|
0
|
|
|
|
0
|
return ($_[0] ? $dir . '/PDL' : $dir) |
|
|
0
|
|
|
|
|
|
109
|
|
|
|
|
|
|
if -e "$dir/PDL/Core/Dev.pm"; |
110
|
|
|
|
|
|
|
} |
111
|
0
|
0
|
|
|
|
0
|
die "Unable to determine INSTALLED directory path to PDL::Core::Dev module\n" |
112
|
|
|
|
|
|
|
if !$_[0]; |
113
|
0
|
|
|
|
|
0
|
return undef; |
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
# |
117
|
|
|
|
|
|
|
# To access PDL's configuration use %PDL::Config. Makefile.PL has been set up |
118
|
|
|
|
|
|
|
# to create this variable so it is available during 'perl Makefile.PL' and |
119
|
|
|
|
|
|
|
# it can be eval-ed during 'make' |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
unless ( %PDL::Config ) { |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
# look for the distribution and then the installed version |
124
|
|
|
|
|
|
|
# (a manual version of whereami_any) |
125
|
|
|
|
|
|
|
# |
126
|
|
|
|
|
|
|
my $dir; |
127
|
|
|
|
|
|
|
$dir = whereami(1); |
128
|
|
|
|
|
|
|
if ( defined $dir ) { |
129
|
|
|
|
|
|
|
$dir = abs_path($dir . "/Core"); |
130
|
|
|
|
|
|
|
} else { |
131
|
|
|
|
|
|
|
# as no argument given whereami_inst will die if it fails |
132
|
|
|
|
|
|
|
# (and it also returns a slightly different path than whereami(1) |
133
|
|
|
|
|
|
|
# does, since it does not include "/PDL") |
134
|
|
|
|
|
|
|
# |
135
|
|
|
|
|
|
|
$dir = whereami_inst; |
136
|
|
|
|
|
|
|
$dir = abs_path($dir . "/PDL"); |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
my $dir2 = $dir; |
140
|
|
|
|
|
|
|
$dir2 =~ s/\}/\\\}/g; |
141
|
|
|
|
|
|
|
eval sprintf('require q{%s/Config.pm};', $dir2); |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
die "Unable to find PDL's configuration info\n [$@]" |
144
|
|
|
|
|
|
|
if $@; |
145
|
|
|
|
|
|
|
} |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
# Data types to C types mapping |
148
|
|
|
|
|
|
|
# get the map from Types.pm |
149
|
|
|
|
|
|
|
{ |
150
|
|
|
|
|
|
|
# load PDL::Types only if it has not been previously loaded |
151
|
|
|
|
|
|
|
my $loaded_types = grep (m%(PDL|Core)/Types[.]pm$%, keys %INC); |
152
|
|
|
|
|
|
|
$@ = ''; # reset |
153
|
|
|
|
|
|
|
eval('require "'.whereami_any().'/Core/Types.pm"') # lets dist Types.pm win |
154
|
|
|
|
|
|
|
unless $loaded_types; # only when PDL::Types not yet loaded |
155
|
|
|
|
|
|
|
if($@) { # if PDL::Types doesn't work try with full path (during build) |
156
|
|
|
|
|
|
|
my $foo = $@; |
157
|
|
|
|
|
|
|
$@=""; |
158
|
|
|
|
|
|
|
eval('require PDL::Types'); |
159
|
|
|
|
|
|
|
if($@) { |
160
|
|
|
|
|
|
|
die "can't find PDL::Types: $foo and $@" unless $@ eq ""; |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
} |
164
|
|
|
|
|
|
|
PDL::Types->import(); |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
my $inc = defined $PDL::Config{MALLOCDBG}->{include} ? |
167
|
|
|
|
|
|
|
"$PDL::Config{MALLOCDBG}->{include}" : ''; |
168
|
|
|
|
|
|
|
my $libs = defined $PDL::Config{MALLOCDBG}->{libs} ? |
169
|
|
|
|
|
|
|
"$PDL::Config{MALLOCDBG}->{libs}" : ''; |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
%PDL_DATATYPES = (); |
172
|
|
|
|
|
|
|
foreach $key (keys %PDL::Types::typehash) { |
173
|
|
|
|
|
|
|
$PDL_DATATYPES{$PDL::Types::typehash{$key}->{'sym'}} = |
174
|
|
|
|
|
|
|
$PDL::Types::typehash{$key}->{'ctype'}; |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
# non-blocking IO configuration |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
$O_NONBLOCK = defined $Config{'o_nonblock'} ? $Config{'o_nonblock'} |
180
|
|
|
|
|
|
|
: 'O_NONBLOCK'; |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
=head2 isbigendian |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
=for ref |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
Is the machine big or little endian? |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
=for example |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
print "Your machins is big endian.\n" if isbigendian(); |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
returns 1 if the machine is big endian, 0 if little endian, |
193
|
|
|
|
|
|
|
or dies if neither. It uses the C element of |
194
|
|
|
|
|
|
|
perl's C<%Config> array. |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
=for usage |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
my $retval = isbigendian(); |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
=cut |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
# ' emacs parsing dummy |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
# big/little endian? |
205
|
|
|
|
|
|
|
sub isbigendian { |
206
|
6
|
|
|
6
|
|
59
|
use Config; |
|
6
|
|
|
|
|
41
|
|
|
6
|
|
|
|
|
16389
|
|
207
|
|
|
|
|
|
|
my $byteorder = $Config{byteorder} || |
208
|
0
|
|
0
|
0
|
1
|
0
|
die "ERROR: Unable to find 'byteorder' in perl's Config\n"; |
209
|
0
|
0
|
|
|
|
0
|
return 1 if $byteorder eq "4321"; |
210
|
0
|
0
|
|
|
|
0
|
return 1 if $byteorder eq "87654321"; |
211
|
0
|
0
|
|
|
|
0
|
return 0 if $byteorder eq "1234"; |
212
|
0
|
0
|
|
|
|
0
|
return 0 if $byteorder eq "12345678"; |
213
|
0
|
|
|
|
|
0
|
die "ERROR: PDL does not understand your machine's byteorder ($byteorder)\n"; |
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
#################### PDL Generic PreProcessor #################### |
217
|
|
|
|
|
|
|
# |
218
|
|
|
|
|
|
|
# Preprocesses *.g files to *.c files allowing 'generic' |
219
|
|
|
|
|
|
|
# type code which is converted to code for each type. |
220
|
|
|
|
|
|
|
# |
221
|
|
|
|
|
|
|
# e.g. the code: |
222
|
|
|
|
|
|
|
# |
223
|
|
|
|
|
|
|
# pdl x; |
224
|
|
|
|
|
|
|
# GENERICLOOP(x.datatype) |
225
|
|
|
|
|
|
|
# generic *xx = x.data; |
226
|
|
|
|
|
|
|
# for(i=0; i
|
227
|
|
|
|
|
|
|
# xx[i] = i/nvals; |
228
|
|
|
|
|
|
|
# ENDGENERICLOOP |
229
|
|
|
|
|
|
|
# |
230
|
|
|
|
|
|
|
# is converted into a giant switch statement: |
231
|
|
|
|
|
|
|
# |
232
|
|
|
|
|
|
|
# pdl x; |
233
|
|
|
|
|
|
|
# switch (x.datatype) { |
234
|
|
|
|
|
|
|
# |
235
|
|
|
|
|
|
|
# case PDL_L: |
236
|
|
|
|
|
|
|
# { |
237
|
|
|
|
|
|
|
# PDL_Long *xx = x.data; |
238
|
|
|
|
|
|
|
# for(i=0; i
|
239
|
|
|
|
|
|
|
# xx[i] = i/nvals; |
240
|
|
|
|
|
|
|
# }break; |
241
|
|
|
|
|
|
|
# |
242
|
|
|
|
|
|
|
# case PDL_F: |
243
|
|
|
|
|
|
|
# { |
244
|
|
|
|
|
|
|
# PDL_Float *xx = x.data; |
245
|
|
|
|
|
|
|
# |
246
|
|
|
|
|
|
|
# .... etc. ..... |
247
|
|
|
|
|
|
|
# |
248
|
|
|
|
|
|
|
# 'generic' is globally substituted for each relevant data type. |
249
|
|
|
|
|
|
|
# |
250
|
|
|
|
|
|
|
# This is used in PDL to write generic functions (taking pdl or void |
251
|
|
|
|
|
|
|
# objects) which is still efficient with perl writing the actual C |
252
|
|
|
|
|
|
|
# code for each type. |
253
|
|
|
|
|
|
|
# |
254
|
|
|
|
|
|
|
# 1st version - Karl Glazebrook 4/Aug/1996. |
255
|
|
|
|
|
|
|
# |
256
|
|
|
|
|
|
|
# Also makes the followings substitutions: |
257
|
|
|
|
|
|
|
# |
258
|
|
|
|
|
|
|
# (i) O_NONBLOCK - open flag for non-blocking I/O (5/Aug/96) |
259
|
|
|
|
|
|
|
# |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
sub genpp { |
263
|
|
|
|
|
|
|
|
264
|
0
|
|
|
0
|
0
|
0
|
$gotstart = 0; @gencode = (); |
|
0
|
|
|
|
|
0
|
|
265
|
|
|
|
|
|
|
|
266
|
0
|
|
|
|
|
0
|
while (<>) { # Process files in @ARGV list - result to STDOUT |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
# Do the miscellaneous substitutions first |
269
|
|
|
|
|
|
|
|
270
|
0
|
|
|
|
|
0
|
s/O_NONBLOCK/$O_NONBLOCK/go; # I/O |
271
|
|
|
|
|
|
|
|
272
|
0
|
0
|
|
|
|
0
|
if ( m/ (\s*)? \b GENERICLOOP \s* \( ( [^\)]* ) \) ( \s*; )? /x ){ # Start of generic code |
273
|
|
|
|
|
|
|
#print $MATCH, "=$1=\n"; |
274
|
|
|
|
|
|
|
|
275
|
0
|
0
|
|
|
|
0
|
die "Found GENERICLOOP while searching for ENDGENERICLOOP\n" if $gotstart; |
276
|
0
|
|
|
|
|
0
|
$loopvar = $2; |
277
|
0
|
|
|
|
|
0
|
$indent = $1; |
278
|
0
|
|
|
|
|
0
|
print $PREMATCH; |
279
|
|
|
|
|
|
|
|
280
|
0
|
|
|
|
|
0
|
@gencode = (); # Start saving code |
281
|
0
|
|
|
|
|
0
|
push @gencode, $POSTMATCH; |
282
|
0
|
|
|
|
|
0
|
$gotstart = 1; |
283
|
0
|
|
|
|
|
0
|
next; |
284
|
|
|
|
|
|
|
} |
285
|
|
|
|
|
|
|
|
286
|
0
|
0
|
|
|
|
0
|
if ( m/ \b ENDGENERICLOOP ( \s*; )? /x ) { |
287
|
|
|
|
|
|
|
|
288
|
0
|
0
|
|
|
|
0
|
die "Found ENDGENERICLOOP while searching for GENERICLOOP\n" unless $gotstart; |
289
|
|
|
|
|
|
|
|
290
|
0
|
|
|
|
|
0
|
push @gencode, $PREMATCH; |
291
|
|
|
|
|
|
|
|
292
|
0
|
|
|
|
|
0
|
flushgeneric(); # Output the generic code |
293
|
|
|
|
|
|
|
|
294
|
0
|
|
|
|
|
0
|
print $POSTMATCH; # End of genric code |
295
|
0
|
|
|
|
|
0
|
$gotstart = 0; |
296
|
0
|
|
|
|
|
0
|
next; |
297
|
|
|
|
|
|
|
} |
298
|
|
|
|
|
|
|
|
299
|
0
|
0
|
|
|
|
0
|
if ($gotstart) { |
300
|
0
|
|
|
|
|
0
|
push @gencode, $_; |
301
|
|
|
|
|
|
|
} |
302
|
|
|
|
|
|
|
else { |
303
|
0
|
|
|
|
|
0
|
print; |
304
|
|
|
|
|
|
|
} |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
} # End while |
307
|
|
|
|
|
|
|
} |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
sub flushgeneric { # Construct the generic code switch |
310
|
|
|
|
|
|
|
|
311
|
0
|
|
|
0
|
0
|
0
|
print $indent,"switch ($loopvar) {\n\n"; |
312
|
|
|
|
|
|
|
|
313
|
0
|
|
|
|
|
0
|
for $case (PDL::Types::typesrtkeys()){ |
314
|
|
|
|
|
|
|
|
315
|
0
|
|
|
|
|
0
|
$type = $PDL_DATATYPES{$case}; |
316
|
|
|
|
|
|
|
|
317
|
0
|
|
|
|
|
0
|
my $ppsym = $PDL::Types::typehash{$case}->{ppsym}; |
318
|
0
|
|
|
|
|
0
|
print $indent,"case $case:\n"; # Start of this case |
319
|
0
|
|
|
|
|
0
|
print $indent," {"; |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
# Now output actual code with substutions |
322
|
|
|
|
|
|
|
|
323
|
0
|
|
|
|
|
0
|
for (@gencode) { |
324
|
0
|
|
|
|
|
0
|
$line = $_; |
325
|
|
|
|
|
|
|
|
326
|
0
|
|
|
|
|
0
|
$line =~ s/\bgeneric\b/$type/g; |
327
|
0
|
|
|
|
|
0
|
$line =~ s/\bgeneric_ppsym\b/$ppsym/g; |
328
|
|
|
|
|
|
|
|
329
|
0
|
|
|
|
|
0
|
print " ",$line; |
330
|
|
|
|
|
|
|
} |
331
|
|
|
|
|
|
|
|
332
|
0
|
|
|
|
|
0
|
print "}break;\n\n"; # End of this case |
333
|
|
|
|
|
|
|
} |
334
|
0
|
|
|
|
|
0
|
print $indent,"default:\n"; |
335
|
0
|
|
|
|
|
0
|
print $indent,' croak ("Not a known data type code=%d",'.$loopvar.");\n"; |
336
|
0
|
|
|
|
|
0
|
print $indent,"}"; |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
} |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
sub _oneliner { |
341
|
0
|
|
|
0
|
|
0
|
my ($cmd) = @_; |
342
|
0
|
|
|
|
|
0
|
require ExtUtils::MM; |
343
|
0
|
|
|
|
|
0
|
my $MM = bless { NAME => 'Fake' }, 'MM'; |
344
|
0
|
|
|
|
|
0
|
$MM->oneliner($cmd); |
345
|
|
|
|
|
|
|
} |
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
sub genpp_cmdline { |
348
|
0
|
|
|
0
|
0
|
0
|
my ($in, $out) = @_; |
349
|
0
|
|
|
|
|
0
|
my $devpm = whereami_any()."/Core/Dev.pm"; |
350
|
0
|
|
|
|
|
0
|
sprintf(_oneliner(<<'EOF'), $devpm) . qq{ "$in" > "$out"}; |
351
|
|
|
|
|
|
|
require "%s"; PDL::Core::Dev->import(); genpp(); |
352
|
|
|
|
|
|
|
EOF |
353
|
|
|
|
|
|
|
} |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
# Standard PDL postamble |
357
|
|
|
|
|
|
|
# |
358
|
|
|
|
|
|
|
# This is called via .../Gen/Inline/Pdlpp.pm, in the case that the INTERNAL |
359
|
|
|
|
|
|
|
# flag for the compilation is off (grep "ILSM" in that file to find the reference). |
360
|
|
|
|
|
|
|
# If it's ON, then postamble_int gets called instead. |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
sub postamble { |
364
|
0
|
|
|
0
|
0
|
0
|
my ($self) = @_; |
365
|
0
|
|
|
|
|
0
|
sprintf <<'EOF', genpp_cmdline(qw($< $@)); |
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
# Rules for the generic preprocessor |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
.SUFFIXES: .g |
370
|
|
|
|
|
|
|
.g.c : |
371
|
|
|
|
|
|
|
%s |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
EOF |
374
|
|
|
|
|
|
|
} |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
# Expects list in format: |
377
|
|
|
|
|
|
|
# [gtest.pd, GTest, PDL::GTest, ['../GIS/Proj', ...] ], [...] |
378
|
|
|
|
|
|
|
# source, prefix,module/package, optional deps |
379
|
|
|
|
|
|
|
# The idea is to support in future several packages in same dir - EUMM |
380
|
|
|
|
|
|
|
# 7.06 supports |
381
|
|
|
|
|
|
|
# each optional dep is a relative dir that a "make" will chdir to and |
382
|
|
|
|
|
|
|
# "make" first - so the *.pd file can then "use" what it makes |
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
# This is the function internal for PDL. |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
sub pdlpp_postamble_int { |
387
|
0
|
|
|
0
|
0
|
0
|
join '',map { my($src,$pref,$mod, $deps) = @$_; |
|
0
|
|
|
|
|
0
|
|
388
|
0
|
0
|
0
|
|
|
0
|
die "If give dependencies, must be array-ref" if $deps and !ref $deps; |
389
|
0
|
|
|
|
|
0
|
my $w = whereami_any(); |
390
|
0
|
|
|
|
|
0
|
$w =~ s%/((PDL)|(Basic))$%%; # remove the trailing subdir |
391
|
0
|
|
|
|
|
0
|
my $top = File::Spec->abs2rel($w); |
392
|
0
|
|
|
|
|
0
|
my $basic = File::Spec->catdir($top, 'Basic'); |
393
|
0
|
|
|
|
|
0
|
my $core = File::Spec->catdir($basic, 'Core'); |
394
|
0
|
|
|
|
|
0
|
my $gen = File::Spec->catdir($basic, 'Gen'); |
395
|
0
|
|
|
|
|
0
|
my $depbuild = ''; |
396
|
0
|
0
|
|
|
|
0
|
for my $dep (@{$deps || []}) { |
|
0
|
|
|
|
|
0
|
|
397
|
0
|
|
|
|
|
0
|
my $target = ''; |
398
|
0
|
0
|
|
|
|
0
|
if ($dep eq 'core') { |
399
|
0
|
|
|
|
|
0
|
$dep = $top; |
400
|
0
|
|
|
|
|
0
|
$target = ' core'; |
401
|
|
|
|
|
|
|
} |
402
|
0
|
|
|
|
|
0
|
$dep =~ s#([\(\)])#\\$1#g; # in case of unbalanced ( |
403
|
0
|
|
|
|
|
0
|
$depbuild .= _oneliner("exit(!(chdir q($dep) && !system(q(\$(MAKE)$target))))"); |
404
|
0
|
|
|
|
|
0
|
$depbuild .= "\n\t"; |
405
|
|
|
|
|
|
|
} |
406
|
|
|
|
|
|
|
qq| |
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
$pref.pm: $src $core/Types.pm |
409
|
|
|
|
|
|
|
$depbuild\$(PERLRUNINST) \"-MPDL::PP qw[$mod $mod $pref]\" $src |
410
|
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
$pref.xs: $pref.pm |
412
|
|
|
|
|
|
|
\$(TOUCH) \$@ |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
$pref.c: $pref.xs |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
$pref\$(OBJ_EXT): $pref.c |
417
|
|
|
|
|
|
|
| |
418
|
0
|
|
|
|
|
0
|
} (@_) |
419
|
|
|
|
|
|
|
} |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
# This is the function to be used outside the PDL tree. |
423
|
|
|
|
|
|
|
sub pdlpp_postamble { |
424
|
0
|
|
|
0
|
0
|
0
|
join '',map { my($src,$pref,$mod) = @$_; |
|
0
|
|
|
|
|
0
|
|
425
|
0
|
|
|
|
|
0
|
my $w = whereami_any(); |
426
|
0
|
|
|
|
|
0
|
$w =~ s%/((PDL)|(Basic))$%%; # remove the trailing subdir |
427
|
0
|
|
|
|
|
0
|
my $oneliner = _oneliner(qq{exit if \$ENV{DESTDIR}; use PDL::Doc; eval { PDL::Doc::add_module(q{$mod}); }}); |
428
|
0
|
|
|
|
|
0
|
qq| |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
$pref.pm: $src |
431
|
|
|
|
|
|
|
\$(PERL) "-I$w" \"-MPDL::PP qw[$mod $mod $pref]\" $src |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
$pref.xs: $pref.pm |
434
|
|
|
|
|
|
|
\$(TOUCH) \$@ |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
$pref.c: $pref.xs |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
$pref\$(OBJ_EXT): $pref.c |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
install :: |
441
|
|
|
|
|
|
|
\@echo "Updating PDL documentation database..."; |
442
|
|
|
|
|
|
|
$oneliner |
443
|
|
|
|
|
|
|
| |
444
|
|
|
|
|
|
|
} (@_) |
445
|
|
|
|
|
|
|
} |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
sub pdlpp_stdargs_int { |
448
|
0
|
|
|
0
|
0
|
0
|
my($rec) = @_; |
449
|
0
|
|
|
|
|
0
|
my($src,$pref,$mod) = @$rec; |
450
|
0
|
|
|
|
|
0
|
my $w = whereami(); |
451
|
|
|
|
|
|
|
my $malloclib = exists $PDL::Config{MALLOCDBG}->{libs} ? |
452
|
0
|
0
|
|
|
|
0
|
$PDL::Config{MALLOCDBG}->{libs} : ''; |
453
|
|
|
|
|
|
|
my $mallocinc = exists $PDL::Config{MALLOCDBG}->{include} ? |
454
|
0
|
0
|
|
|
|
0
|
$PDL::Config{MALLOCDBG}->{include} : ''; |
455
|
0
|
0
|
0
|
|
|
0
|
my $libsarg = $libs || $malloclib ? "$libs $malloclib " : ''; # for Win32 |
456
|
|
|
|
|
|
|
return ( |
457
|
0
|
0
|
|
|
|
0
|
%::PDL_OPTIONS, |
|
|
0
|
|
|
|
|
|
458
|
|
|
|
|
|
|
'NAME' => $mod, |
459
|
|
|
|
|
|
|
'VERSION_FROM' => "$w/Basic/Core/Version.pm", |
460
|
|
|
|
|
|
|
'TYPEMAPS' => [&PDL_TYPEMAP()], |
461
|
|
|
|
|
|
|
'OBJECT' => "$pref\$(OBJ_EXT)", |
462
|
|
|
|
|
|
|
PM => {"$pref.pm" => "\$(INST_LIBDIR)/$pref.pm"}, |
463
|
|
|
|
|
|
|
MAN3PODS => {"$pref.pm" => "\$(INST_MAN3DIR)/$mod.\$(MAN3EXT)"}, |
464
|
|
|
|
|
|
|
'INC' => &PDL_INCLUDE()." $inc $mallocinc", |
465
|
|
|
|
|
|
|
'LIBS' => $libsarg ? [$libsarg] : [], |
466
|
|
|
|
|
|
|
'clean' => {'FILES' => "$pref.xs $pref.pm $pref\$(OBJ_EXT) $pref.c"}, |
467
|
|
|
|
|
|
|
(eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), |
468
|
|
|
|
|
|
|
); |
469
|
|
|
|
|
|
|
} |
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
sub pdlpp_stdargs { |
472
|
2
|
|
|
2
|
0
|
6
|
my($rec) = @_; |
473
|
2
|
|
|
|
|
8
|
my($src,$pref,$mod) = @$rec; |
474
|
|
|
|
|
|
|
return ( |
475
|
2
|
50
|
|
|
|
9
|
%::PDL_OPTIONS, |
|
|
50
|
|
|
|
|
|
476
|
|
|
|
|
|
|
'NAME' => $mod, |
477
|
|
|
|
|
|
|
'TYPEMAPS' => [&PDL_INST_TYPEMAP()], |
478
|
|
|
|
|
|
|
'OBJECT' => "$pref\$(OBJ_EXT)", |
479
|
|
|
|
|
|
|
PM => {"$pref.pm" => "\$(INST_LIBDIR)/$pref.pm"}, |
480
|
|
|
|
|
|
|
MAN3PODS => {"$pref.pm" => "\$(INST_MAN3DIR)/$mod.\$(MAN3EXT)"}, |
481
|
|
|
|
|
|
|
'INC' => &PDL_INST_INCLUDE()." $inc", |
482
|
|
|
|
|
|
|
'LIBS' => $libs ? ["$libs "] : [], |
483
|
|
|
|
|
|
|
'clean' => {'FILES' => "$pref.xs $pref.pm $pref\$(OBJ_EXT) $pref.c"}, |
484
|
|
|
|
|
|
|
'dist' => {'PREOP' => '$(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" -MPDL::Core::Dev -e pdlpp_mkgen $(DISTVNAME)' }, |
485
|
|
|
|
|
|
|
(eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), |
486
|
|
|
|
|
|
|
); |
487
|
|
|
|
|
|
|
} |
488
|
|
|
|
|
|
|
|
489
|
|
|
|
|
|
|
# pdlpp_mkgen($dir) |
490
|
|
|
|
|
|
|
# - scans $dir/MANIFEST for all *.pd files and creates corresponding *.pm files |
491
|
|
|
|
|
|
|
# in $dir/GENERATED/ subdir; needed for proper doc rendering at metacpan.org |
492
|
|
|
|
|
|
|
# - it is used in Makefile.PL like: |
493
|
|
|
|
|
|
|
# dist => { PREOP=>'$(PERL) -MPDL::Core::Dev -e pdlpp_mkgen $(DISTVNAME)' } |
494
|
|
|
|
|
|
|
# so all the magic *.pm generation happens during "make dist" |
495
|
|
|
|
|
|
|
# - it is intended to be called as a one-liner: |
496
|
|
|
|
|
|
|
# perl -MPDL::Core::Dev -e pdlpp_mkgen DirName |
497
|
|
|
|
|
|
|
# |
498
|
|
|
|
|
|
|
sub pdlpp_mkgen { |
499
|
0
|
0
|
|
0
|
0
|
|
my $dir = @_ > 0 ? $_[0] : $ARGV[0]; |
500
|
0
|
0
|
0
|
|
|
|
die "pdlpp_mkgen: unspecified directory" unless defined $dir && -d $dir; |
501
|
0
|
|
|
|
|
|
my $file = "$dir/MANIFEST"; |
502
|
0
|
0
|
|
|
|
|
die "pdlpp_mkgen: non-existing '$dir/MANIFEST'" unless -f $file; |
503
|
|
|
|
|
|
|
|
504
|
0
|
|
|
|
|
|
my @pairs = (); |
505
|
0
|
|
|
|
|
|
my $manifest = ExtUtils::Manifest::maniread($file); |
506
|
0
|
|
|
|
|
|
for (keys %$manifest) { |
507
|
0
|
0
|
|
|
|
|
next if $_ !~ m/\.pd$/; # skip non-pd files |
508
|
0
|
0
|
|
|
|
|
next if $_ =~ m/^(t|xt)\//; # skip *.pd files in test subdirs |
509
|
0
|
0
|
|
|
|
|
next unless -f $_; |
510
|
0
|
|
|
|
|
|
my $content = do { local $/; open my $in, '<', $_; <$in> }; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
511
|
0
|
0
|
|
|
|
|
if ($content =~ /=head1\s+NAME\s+(\S+)\s+/sg) { |
512
|
0
|
|
|
|
|
|
push @pairs, [$_, $1]; |
513
|
|
|
|
|
|
|
} |
514
|
|
|
|
|
|
|
else { |
515
|
0
|
|
|
|
|
|
warn "pdlpp_mkgen: unknown module name for '$_' (use proper '=head1 NAME' section)\n"; |
516
|
|
|
|
|
|
|
} |
517
|
|
|
|
|
|
|
} |
518
|
|
|
|
|
|
|
|
519
|
0
|
|
|
|
|
|
my %added = (); |
520
|
0
|
|
|
|
|
|
for (@pairs) { |
521
|
0
|
|
|
|
|
|
my ($pd, $mod) = @$_; |
522
|
0
|
|
|
|
|
|
(my $prefix = $mod) =~ s|::|/|g; |
523
|
0
|
|
|
|
|
|
my $manifestpm = "GENERATED/$prefix.pm"; |
524
|
0
|
|
|
|
|
|
$prefix = "$dir/GENERATED/$prefix"; |
525
|
0
|
|
|
|
|
|
File::Path::mkpath(dirname($prefix)); |
526
|
|
|
|
|
|
|
#there is no way to use PDL::PP from perl code, thus calling via system() |
527
|
0
|
|
|
|
|
|
my @in = map { "-I$_" } @INC, 'inc'; |
|
0
|
|
|
|
|
|
|
528
|
0
|
|
|
|
|
|
my $rv = system($^X, @in, "-MPDL::PP qw[$mod $mod $prefix]", $pd); |
529
|
0
|
0
|
0
|
|
|
|
if ($rv == 0 && -f "$prefix.pm") { |
530
|
0
|
|
|
|
|
|
$added{$manifestpm} = "mod=$mod pd=$pd (added by pdlpp_mkgen)"; |
531
|
0
|
|
|
|
|
|
unlink "$prefix.xs"; #we need only .pm |
532
|
|
|
|
|
|
|
} |
533
|
|
|
|
|
|
|
else { |
534
|
0
|
|
|
|
|
|
warn "pdlpp_mkgen: cannot convert '$pd'\n"; |
535
|
|
|
|
|
|
|
} |
536
|
|
|
|
|
|
|
} |
537
|
|
|
|
|
|
|
|
538
|
0
|
0
|
|
|
|
|
if (scalar(keys %added) > 0) { |
539
|
|
|
|
|
|
|
#maniadd works only with this global variable |
540
|
0
|
|
|
|
|
|
local $ExtUtils::Manifest::MANIFEST = $file; |
541
|
0
|
|
|
|
|
|
ExtUtils::Manifest::maniadd(\%added); |
542
|
|
|
|
|
|
|
} |
543
|
|
|
|
|
|
|
} |
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
sub unsupported { |
546
|
0
|
|
|
0
|
0
|
|
my ($package,$os) = @_; |
547
|
0
|
|
|
|
|
|
"No support for $package on $os platform yet. Will skip build process"; |
548
|
|
|
|
|
|
|
} |
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
sub write_dummy_make { |
551
|
0
|
|
|
0
|
0
|
|
my ($msg) = @_; |
552
|
0
|
|
|
|
|
|
$msg =~ s#\n*\z#\n#; |
553
|
0
|
|
|
|
|
|
$msg =~ s#^\s*#\n#gm; |
554
|
0
|
|
|
|
|
|
print $msg; |
555
|
0
|
|
|
|
|
|
require ExtUtils::MakeMaker; |
556
|
0
|
|
|
|
|
|
ExtUtils::MakeMaker::WriteEmptyMakefile(NAME => 'Dummy', DIR => []); |
557
|
|
|
|
|
|
|
} |
558
|
|
|
|
|
|
|
|
559
|
|
|
|
|
|
|
sub getcyglib { |
560
|
0
|
|
|
0
|
0
|
|
my ($lib) = @_; |
561
|
0
|
|
|
|
|
|
my $lp = `gcc -print-file-name=lib$lib.a`; |
562
|
0
|
|
|
|
|
|
$lp =~ s|/[^/]+$||; |
563
|
0
|
|
|
|
|
|
$lp =~ s|^([a-z,A-Z]):|//$1|g; |
564
|
0
|
|
|
|
|
|
return "-L$lp -l$lib"; |
565
|
|
|
|
|
|
|
} |
566
|
|
|
|
|
|
|
|
567
|
|
|
|
|
|
|
=head2 trylink |
568
|
|
|
|
|
|
|
|
569
|
|
|
|
|
|
|
=for ref |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
a perl configure clone |
572
|
|
|
|
|
|
|
|
573
|
|
|
|
|
|
|
=for example |
574
|
|
|
|
|
|
|
|
575
|
|
|
|
|
|
|
if (trylink 'libGL', '', 'char glBegin(); glBegin();', '-lGL') { |
576
|
|
|
|
|
|
|
$libs = '-lGLU -lGL'; |
577
|
|
|
|
|
|
|
$have_GL = 1; |
578
|
|
|
|
|
|
|
} else { |
579
|
|
|
|
|
|
|
$have_GL = 0; |
580
|
|
|
|
|
|
|
} |
581
|
|
|
|
|
|
|
$maybe = |
582
|
|
|
|
|
|
|
trylink 'libwhatever', $inc, $body, $libs, $cflags, |
583
|
|
|
|
|
|
|
{MakeMaker=>1, Hide=>0, Clean=>1}; |
584
|
|
|
|
|
|
|
|
585
|
|
|
|
|
|
|
Try to link some C-code making up the body of a function |
586
|
|
|
|
|
|
|
with a given set of library specifiers |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
return 1 if successful, 0 otherwise |
589
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
=for usage |
591
|
|
|
|
|
|
|
|
592
|
|
|
|
|
|
|
trylink $infomsg, $include, $progbody, $libs [,$cflags,{OPTIONS}]; |
593
|
|
|
|
|
|
|
|
594
|
|
|
|
|
|
|
Takes 4 + 2 optional arguments. |
595
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
=over 5 |
597
|
|
|
|
|
|
|
|
598
|
|
|
|
|
|
|
=item * |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
an informational message to print (can be empty) |
601
|
|
|
|
|
|
|
|
602
|
|
|
|
|
|
|
=item * |
603
|
|
|
|
|
|
|
|
604
|
|
|
|
|
|
|
any commands to be included at the top of the generated C program |
605
|
|
|
|
|
|
|
(typically something like C<#include "mylib.h">) |
606
|
|
|
|
|
|
|
|
607
|
|
|
|
|
|
|
=item * |
608
|
|
|
|
|
|
|
|
609
|
|
|
|
|
|
|
the body of the program (in function main) |
610
|
|
|
|
|
|
|
|
611
|
|
|
|
|
|
|
=item * |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
library flags to use for linking. Preprocessing |
614
|
|
|
|
|
|
|
by MakeMaker should be performed as needed (see options and example). |
615
|
|
|
|
|
|
|
|
616
|
|
|
|
|
|
|
=item * |
617
|
|
|
|
|
|
|
|
618
|
|
|
|
|
|
|
compilation flags. For example, something like C<-I/usr/local/lib>. |
619
|
|
|
|
|
|
|
Optional argument. Empty if omitted. |
620
|
|
|
|
|
|
|
|
621
|
|
|
|
|
|
|
=item * |
622
|
|
|
|
|
|
|
|
623
|
|
|
|
|
|
|
OPTIONS |
624
|
|
|
|
|
|
|
|
625
|
|
|
|
|
|
|
=over |
626
|
|
|
|
|
|
|
|
627
|
|
|
|
|
|
|
=item MakeMaker |
628
|
|
|
|
|
|
|
|
629
|
|
|
|
|
|
|
Preprocess library strings in the way MakeMaker does things. This is |
630
|
|
|
|
|
|
|
advisable to ensure that your code will actually work after the link |
631
|
|
|
|
|
|
|
specs have been processed by MakeMaker. |
632
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
=item Hide |
634
|
|
|
|
|
|
|
|
635
|
|
|
|
|
|
|
Controls if linking output etc is hidden from the user or not. |
636
|
|
|
|
|
|
|
On by default except within the build of the PDL distribution |
637
|
|
|
|
|
|
|
where the config value set in F prevails. |
638
|
|
|
|
|
|
|
|
639
|
|
|
|
|
|
|
=item Clean |
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
Remove temporary files. Enabled by default. You might want to switch |
642
|
|
|
|
|
|
|
it off during debugging. |
643
|
|
|
|
|
|
|
|
644
|
|
|
|
|
|
|
=back |
645
|
|
|
|
|
|
|
|
646
|
|
|
|
|
|
|
=back |
647
|
|
|
|
|
|
|
|
648
|
|
|
|
|
|
|
=cut |
649
|
|
|
|
|
|
|
|
650
|
|
|
|
|
|
|
|
651
|
|
|
|
|
|
|
sub trylink { |
652
|
0
|
0
|
|
0
|
1
|
|
my $opt = ref $_[$#_] eq 'HASH' ? pop : {}; |
653
|
0
|
|
|
|
|
|
my ($txt,$inc,$body,$libs,$cflags) = @_; |
654
|
0
|
|
0
|
|
|
|
$cflags ||= ''; |
655
|
0
|
|
|
|
|
|
require File::Spec; |
656
|
0
|
|
|
|
|
|
require File::Temp; |
657
|
0
|
|
|
0
|
|
|
my $cdir = sub { return File::Spec->catdir(@_)}; |
|
0
|
|
|
|
|
|
|
658
|
0
|
|
|
0
|
|
|
my $cfile = sub { return File::Spec->catfile(@_)}; |
|
0
|
|
|
|
|
|
|
659
|
6
|
|
|
6
|
|
63
|
use Config; |
|
6
|
|
|
|
|
38
|
|
|
6
|
|
|
|
|
7012
|
|
660
|
|
|
|
|
|
|
|
661
|
|
|
|
|
|
|
# check if MakeMaker should be used to preprocess the libs |
662
|
0
|
|
|
|
|
|
for my $key(keys %$opt) {$opt->{lc $key} = $opt->{$key}} |
|
0
|
|
|
|
|
|
|
663
|
0
|
|
0
|
|
|
|
my $mmprocess = exists $opt->{makemaker} && $opt->{makemaker}; |
664
|
|
|
|
|
|
|
my $hide = exists $opt->{hide} ? $opt->{hide} : |
665
|
0
|
0
|
|
|
|
|
exists $PDL::Config{HIDE_TRYLINK} ? $PDL::Config{HIDE_TRYLINK} : 1; |
|
|
0
|
|
|
|
|
|
666
|
0
|
0
|
|
|
|
|
my $clean = exists $opt->{clean} ? $opt->{clean} : 1; |
667
|
0
|
0
|
|
|
|
|
if ($mmprocess) { |
668
|
0
|
|
|
|
|
|
require ExtUtils::MakeMaker; |
669
|
0
|
|
|
|
|
|
require ExtUtils::Liblist; |
670
|
0
|
|
|
|
|
|
my $self = new ExtUtils::MakeMaker {DIR => [],'NAME' => 'NONE'}; |
671
|
|
|
|
|
|
|
|
672
|
0
|
|
|
|
|
|
my @libs = $self->ext($libs, 0); |
673
|
|
|
|
|
|
|
|
674
|
0
|
0
|
|
|
|
|
print "processed LIBS: $libs[0]\n" unless $hide; |
675
|
0
|
|
|
|
|
|
$libs = $libs[0]; # replace by preprocessed libs |
676
|
|
|
|
|
|
|
} |
677
|
|
|
|
|
|
|
|
678
|
0
|
0
|
|
|
|
|
print " Trying $txt...\n " unless $txt =~ /^\s*$/; |
679
|
|
|
|
|
|
|
|
680
|
0
|
0
|
|
|
|
|
my $HIDE = !$hide ? '' : '>/dev/null 2>&1'; |
681
|
0
|
0
|
|
|
|
|
if($^O =~ /mswin32/i) {$HIDE = '>NUL 2>&1'} |
|
0
|
|
|
|
|
|
|
682
|
|
|
|
|
|
|
|
683
|
0
|
|
|
|
|
|
my $tempd; |
684
|
|
|
|
|
|
|
|
685
|
0
|
|
0
|
|
|
|
$tempd = File::Temp::tempdir(CLEANUP=>1) || die "trylink: could not make TEMPDIR"; |
686
|
|
|
|
|
|
|
### if($^O =~ /MSWin32/i) {$tempd = File::Spec->tmpdir()} |
687
|
|
|
|
|
|
|
### else { |
688
|
|
|
|
|
|
|
### $tempd = $PDL::Config{TEMPDIR} || |
689
|
|
|
|
|
|
|
### } |
690
|
|
|
|
|
|
|
|
691
|
0
|
|
|
|
|
|
my ($tc,$te) = map {&$cfile($tempd,"testfile$_")} ('.c',''); |
|
0
|
|
|
|
|
|
|
692
|
0
|
0
|
|
|
|
|
open FILE,">$tc" or die "trylink: couldn't open testfile `$tc' for writing, $!"; |
693
|
0
|
|
|
|
|
|
my $prog = <<"EOF"; |
694
|
|
|
|
|
|
|
$inc |
695
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
int main(void) { |
697
|
|
|
|
|
|
|
$body |
698
|
|
|
|
|
|
|
|
699
|
|
|
|
|
|
|
return 0; |
700
|
|
|
|
|
|
|
|
701
|
|
|
|
|
|
|
} |
702
|
|
|
|
|
|
|
|
703
|
|
|
|
|
|
|
EOF |
704
|
|
|
|
|
|
|
|
705
|
0
|
|
|
|
|
|
print FILE $prog; |
706
|
0
|
|
|
|
|
|
close FILE; |
707
|
|
|
|
|
|
|
# print "test prog:\n$prog\n"; |
708
|
|
|
|
|
|
|
# make sure we can overwrite the executable. shouldn't need this, |
709
|
|
|
|
|
|
|
# but if it fails and HIDE is on, the user will never see the error. |
710
|
0
|
0
|
|
|
|
|
open(T, ">$te") or die( "unable to write to test executable `$te'"); |
711
|
0
|
|
|
|
|
|
close T; |
712
|
0
|
0
|
|
|
|
|
print "$Config{cc} $cflags -o $te $tc $libs $HIDE ...\n" unless $hide; |
713
|
0
|
0
|
0
|
|
|
|
my $success = (system("$Config{cc} $cflags -o $te $tc $libs $HIDE") == 0) && |
714
|
|
|
|
|
|
|
-e $te ? 1 : 0; |
715
|
0
|
0
|
|
|
|
|
unlink "$te","$tc" if $clean; |
716
|
0
|
0
|
|
|
|
|
print $success ? "\t\tYES\n" : "\t\tNO\n" unless $txt =~ /^\s*$/; |
|
|
0
|
|
|
|
|
|
717
|
0
|
0
|
0
|
|
|
|
print $success ? "\t\tSUCCESS\n" : "\t\tFAILED\n" |
|
|
0
|
|
|
|
|
|
718
|
|
|
|
|
|
|
if $txt =~ /^\s*$/ && !$hide; |
719
|
0
|
|
|
|
|
|
return $success; |
720
|
|
|
|
|
|
|
} |
721
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
=head2 datatypes_switch |
723
|
|
|
|
|
|
|
|
724
|
|
|
|
|
|
|
=for ref |
725
|
|
|
|
|
|
|
|
726
|
|
|
|
|
|
|
prints on C XS text for F. |
727
|
|
|
|
|
|
|
|
728
|
|
|
|
|
|
|
=cut |
729
|
|
|
|
|
|
|
|
730
|
|
|
|
|
|
|
sub datatypes_switch { |
731
|
0
|
|
|
0
|
1
|
|
my $ntypes = $#PDL::Types::names; |
732
|
0
|
|
|
|
|
|
my @m; |
733
|
0
|
|
|
|
|
|
foreach my $i ( 0 .. $ntypes ) { |
734
|
0
|
|
|
|
|
|
my $type = PDL::Type->new( $i ); |
735
|
0
|
|
|
|
|
|
my $typesym = $type->symbol; |
736
|
0
|
|
|
|
|
|
my $typeppsym = $type->ppsym; |
737
|
0
|
|
|
|
|
|
my $cname = $type->ctype; |
738
|
0
|
|
|
|
|
|
$cname =~ s/^PDL_//; |
739
|
0
|
|
|
|
|
|
push @m, "\tcase $typesym: retval.type = $typesym; retval.value.$typeppsym = PDL.bvals.$cname; break;"; |
740
|
|
|
|
|
|
|
} |
741
|
0
|
|
|
|
|
|
print map "$_\n", @m; |
742
|
|
|
|
|
|
|
} |
743
|
|
|
|
|
|
|
|
744
|
|
|
|
|
|
|
=head2 generate_core_flags |
745
|
|
|
|
|
|
|
|
746
|
|
|
|
|
|
|
=for ref |
747
|
|
|
|
|
|
|
|
748
|
|
|
|
|
|
|
prints on C XS text with core flags, for F. |
749
|
|
|
|
|
|
|
|
750
|
|
|
|
|
|
|
=cut |
751
|
|
|
|
|
|
|
|
752
|
|
|
|
|
|
|
my %flags = ( |
753
|
|
|
|
|
|
|
hdrcpy => { set => 1 }, |
754
|
|
|
|
|
|
|
fflows => { FLAG => "DATAFLOW_F" }, |
755
|
|
|
|
|
|
|
bflows => { FLAG => "DATAFLOW_B" }, |
756
|
|
|
|
|
|
|
is_inplace => { FLAG => "INPLACE", postset => 1 }, |
757
|
|
|
|
|
|
|
donttouch => { FLAG => "DONTTOUCHDATA" }, |
758
|
|
|
|
|
|
|
allocated => { }, |
759
|
|
|
|
|
|
|
vaffine => { FLAG => "OPT_VAFFTRANSOK" }, |
760
|
|
|
|
|
|
|
anychgd => { FLAG => "ANYCHANGED" }, |
761
|
|
|
|
|
|
|
dimschgd => { FLAG => "PARENTDIMSCHANGED" }, |
762
|
|
|
|
|
|
|
tracedebug => { FLAG => "TRACEDEBUG", set => 1}, |
763
|
|
|
|
|
|
|
); |
764
|
|
|
|
|
|
|
#if ( $bvalflag ) { $flags{baddata} = { set => 1, FLAG => "BADVAL" }; } |
765
|
|
|
|
|
|
|
|
766
|
|
|
|
|
|
|
sub generate_core_flags { |
767
|
|
|
|
|
|
|
# access (read, if set is true then write as well; if postset true then |
768
|
|
|
|
|
|
|
# read first and write new value after that) |
769
|
|
|
|
|
|
|
# to piddle's state |
770
|
0
|
|
|
0
|
1
|
|
foreach my $name ( sort keys %flags ) { |
771
|
0
|
|
0
|
|
|
|
my $flag = "PDL_" . ($flags{$name}{FLAG} || uc($name)); |
772
|
0
|
0
|
|
|
|
|
if ( $flags{$name}{set} ) { |
|
|
0
|
|
|
|
|
|
773
|
0
|
|
|
|
|
|
print <<"!WITH!SUBS!"; |
774
|
|
|
|
|
|
|
int |
775
|
|
|
|
|
|
|
$name(x,mode=0) |
776
|
|
|
|
|
|
|
pdl *x |
777
|
|
|
|
|
|
|
int mode |
778
|
|
|
|
|
|
|
CODE: |
779
|
|
|
|
|
|
|
if (items>1) |
780
|
|
|
|
|
|
|
{ setflag(x->state,$flag,mode); } |
781
|
|
|
|
|
|
|
RETVAL = ((x->state & $flag) > 0); |
782
|
|
|
|
|
|
|
OUTPUT: |
783
|
|
|
|
|
|
|
RETVAL |
784
|
|
|
|
|
|
|
|
785
|
|
|
|
|
|
|
!WITH!SUBS! |
786
|
|
|
|
|
|
|
} elsif ($flags{$name}{postset}) { |
787
|
0
|
|
|
|
|
|
print <<"!WITH!SUBS!"; |
788
|
|
|
|
|
|
|
int |
789
|
|
|
|
|
|
|
$name(x,mode=0) |
790
|
|
|
|
|
|
|
pdl *x |
791
|
|
|
|
|
|
|
int mode |
792
|
|
|
|
|
|
|
CODE: |
793
|
|
|
|
|
|
|
RETVAL = ((x->state & $flag) > 0); |
794
|
|
|
|
|
|
|
if (items>1) |
795
|
|
|
|
|
|
|
{ setflag(x->state,$flag,mode); } |
796
|
|
|
|
|
|
|
OUTPUT: |
797
|
|
|
|
|
|
|
RETVAL |
798
|
|
|
|
|
|
|
|
799
|
|
|
|
|
|
|
!WITH!SUBS! |
800
|
|
|
|
|
|
|
} else { |
801
|
0
|
|
|
|
|
|
print <<"!WITH!SUBS!"; |
802
|
|
|
|
|
|
|
int |
803
|
|
|
|
|
|
|
$name(self) |
804
|
|
|
|
|
|
|
pdl *self |
805
|
|
|
|
|
|
|
CODE: |
806
|
|
|
|
|
|
|
RETVAL = ((self->state & $flag) > 0); |
807
|
|
|
|
|
|
|
OUTPUT: |
808
|
|
|
|
|
|
|
RETVAL |
809
|
|
|
|
|
|
|
|
810
|
|
|
|
|
|
|
!WITH!SUBS! |
811
|
|
|
|
|
|
|
} |
812
|
|
|
|
|
|
|
} # foreach: keys %flags |
813
|
|
|
|
|
|
|
} |
814
|
|
|
|
|
|
|
|
815
|
|
|
|
|
|
|
=head2 generate_badval_init |
816
|
|
|
|
|
|
|
|
817
|
|
|
|
|
|
|
=for ref |
818
|
|
|
|
|
|
|
|
819
|
|
|
|
|
|
|
prints on C XS text with badval initialisation, for F. |
820
|
|
|
|
|
|
|
|
821
|
|
|
|
|
|
|
=cut |
822
|
|
|
|
|
|
|
|
823
|
|
|
|
|
|
|
sub generate_badval_init { |
824
|
0
|
|
|
0
|
1
|
|
for my $type (PDL::Types::types()) { |
825
|
0
|
|
|
|
|
|
my $typename = $type->ctype; |
826
|
0
|
|
|
|
|
|
$typename =~ s/^PDL_//; |
827
|
0
|
|
|
|
|
|
my $bval = $type->defbval; |
828
|
0
|
0
|
0
|
|
|
|
if ($PDL::Config{BADVAL_USENAN} && $type->usenan) { |
829
|
|
|
|
|
|
|
# note: no defaults if usenan |
830
|
0
|
|
|
|
|
|
print "\tPDL.bvals.$typename = PDL.NaN_$type;\n"; #Core NaN value |
831
|
|
|
|
|
|
|
} else { |
832
|
0
|
|
|
|
|
|
print "\tPDL.bvals.$typename = PDL.bvals.default_$typename = $bval;\n"; |
833
|
|
|
|
|
|
|
} |
834
|
|
|
|
|
|
|
} |
835
|
|
|
|
|
|
|
# PDL.bvals.Byte = PDL.bvals.default_Byte = UCHAR_MAX; |
836
|
|
|
|
|
|
|
# PDL.bvals.Short = PDL.bvals.default_Short = SHRT_MIN; |
837
|
|
|
|
|
|
|
# PDL.bvals.Ushort = PDL.bvals.default_Ushort = USHRT_MAX; |
838
|
|
|
|
|
|
|
# PDL.bvals.Long = PDL.bvals.default_Long = INT_MIN; |
839
|
|
|
|
|
|
|
|
840
|
|
|
|
|
|
|
} |
841
|
|
|
|
|
|
|
|
842
|
|
|
|
|
|
|
1; |