1use v5.10;
2use strict;
3use warnings;
4
5my $gdal_src_root = shift @ARGV;
6
7my @h_files = (
8    'gcore/gdal.h',
9    'ogr/ogr_api.h',
10    'ogr/ogr_srs_api.h',
11    'apps/gdal_utils.h'
12    );
13
14my %pre = (
15    CPL_C_START => '',
16    CPL_DLL => '',
17    CPL_STDCALL => '',
18    CPL_WARN_UNUSED_RESULT => '',
19    CPL_RESTRICT => ''
20    );
21
22my %constants = (
23    GDALDataType => 1,
24    GDALAsyncStatusType => 1,
25    GDALColorInterp => 1,
26    GDALPaletteInterp => 1,
27    GDALAccess => 1,
28    GDALRWFlag => 1,
29    OGRwkbGeometryType => 1,
30    GDALRATFieldUsage => 1,
31    GDALRATFieldType => 1,
32    GDALRATTableType => 1,
33    GDALTileOrganization => 1,
34    OGRwkbByteOrder => 1,
35    OGRFieldType => 1,
36    OGRFieldSubType => 1,
37    OGRJustification => 1,
38    OGRSTClassId => 1,
39    OGRSTUnitId => 1,
40    OGRAxisOrientation => 1,
41    GDALGridAlgorithm => 1,
42    );
43
44my %callbacks = (
45    CPLErrorHandler => 1,
46    GDALProgressFunc => 1,
47    GDALDerivedPixelFunc => 1,
48    GDALTransformerFunc => 1,
49    GDALContourWriter => 1,
50    );
51
52my %char_p_p_ok = (
53    OGR_G_CreateFromWkt => 1,
54    OGR_G_ImportFromWkt => 1,
55    OGR_G_ExportToWkt => 1,
56    OGR_G_ExportToIsoWkt => 1,
57    OSRExportToWkt => 1,
58    OSRExportToPrettyWkt => 1,
59    OSRExportToProj4 => 1,
60    OSRExportToPCI => 1,
61    OSRExportToXML => 1,
62    OSRExportToMICoordSys => 1,
63    );
64
65my %use_CSL = (
66    GDALCreate => 1,
67    GDALOpenEx => 1,
68    GDALCreateCopy => 1,
69    GDALGetMetadataDomainList => 1,
70    GDALIdentifyDriver => 1,
71    GDALIdentifyDriverEx => 1,
72    GDALValidateCreationOptions => 1,
73    GDALGetMetadata => 1,
74    GDALSetMetadata => 1,
75    GDALGetFileList => 1,
76    GDALAddBand => 1,
77    GDALDatasetCreateLayer => 1,
78    GDALDatasetCopyLayer => 1,
79    OGR_DS_CreateLayer => 1,
80    OGR_DS_CopyLayer => 1,
81    GDALGetRasterCategoryNames => 1,
82    OGR_F_GetFieldAsStringList => 1,
83    OGR_F_SetFieldStringList => 1,
84    OGR_G_ExportToGMLEx => 1,
85    OGR_G_ExportToJsonEx => 1,
86    GDALInfoOptionsNew => 1,
87    GDALTranslateOptionsNew => 1,
88    GDALWarpAppOptionsNew => 1,
89    GDALVectorTranslateOptionsNew => 1,
90    GDALDEMProcessingOptionsNew => 1,
91    GDALNearblackOptionsNew => 1,
92    GDALGridOptionsNew => 1,
93    GDALRasterizeOptionsNew => 1,
94    GDALBuildVRTOptionsNew => 1,
95    GDALBuildVRT => 1,
96    OGR_L_Intersection => 1,
97    OGR_L_Union => 1,
98    OGR_L_SymDifference => 1,
99    OGR_L_Identity => 1,
100    OGR_L_Update => 1,
101    OGR_L_Clip => 1,
102    OGR_L_Erase => 1,
103    );
104
105# these return strings which must be freed
106my %use_ret_opaque = (
107    OGR_G_ExportToGML => 1,
108    OGR_G_ExportToGMLEx => 1,
109    OGR_G_ExportToKML => 1,
110    OGR_G_ExportToJson => 1,
111    OGR_G_ExportToJsonEx => 1,
112    );
113
114my %ret_string_ok = (
115    GDALGetDataTypeName => 1,
116    GDALGetAsyncStatusTypeName => 1,
117    GDALGetColorInterpretationName => 1,
118    GDALGetPaletteInterpretationName => 1,
119    GDALGetDriverShortName => 1,
120    GDALGetDriverLongName => 1,
121    GDALGetDriverHelpTopic => 1,
122    GDALGetDriverCreationOptionList => 1,
123    GDALGetMetadataItem => 1,
124    GDALGetDescription => 1,
125    GDALGetProjectionRef => 1,
126    GDALGetGCPProjection => 1,
127    GDALGetRasterUnitType => 1,
128    GDALDecToDMS => 1,
129    OGR_G_GetGeometryName => 1,
130    );
131
132my %use_array = (
133    OGR_F_SetFieldIntegerList => 1,
134    OGR_F_SetFieldInteger64List => 1,
135    OGR_F_SetFieldDoubleList => 1,
136    );
137
138my %use_opaque_array = (
139    GDALWarp => 1,
140    GDALVectorTranslate => 1,
141    GDALBuildVRT => 1,
142    );
143
144my %use_ret_pointer = (
145    OGR_F_GetFieldAsIntegerList => 1,
146    OGR_F_GetFieldAsInteger64List => 1,
147    OGR_F_GetFieldAsDoubleList => 1,
148    );
149
150my %use_string = (
151    OGR_G_CreateFromWkb => 1,
152    OGR_G_CreateFromFgf => 1,
153    OGR_G_ImportFromWkb => 1,
154    );
155
156my %opaque_pointers = (
157    GDAL_GCP => 1,
158    GDALRPCInfo => 1,
159    CPLXMLNode => 1,
160    GDALRasterIOExtraArg => 1,
161    GDALGridContext => 1,
162    CPLVirtualMem => 1,
163    OGRField => 1,
164    GDALInfoOptions => 1,
165    GDALInfoOptionsForBinary => 1,
166    GDALTranslateOptions => 1,
167    GDALTranslateOptionsForBinary => 1,
168    GDALWarpAppOptions => 1,
169    GDALWarpAppOptionsForBinary => 1,
170    GDALVectorTranslateOptions => 1,
171    GDALVectorTranslateOptionsForBinary => 1,
172    GDALDEMProcessingOptions => 1,
173    GDALDEMProcessingOptionsForBinary => 1,
174    GDALNearblackOptions => 1,
175    GDALNearblackOptionsForBinary => 1,
176    GDALGridOptions => 1,
177    GDALGridOptionsForBinary => 1,
178    GDALRasterizeOptions => 1,
179    GDALRasterizeOptionsForBinary => 1,
180    GDALBuildVRTOptions => 1,
181    GDALBuildVRTOptionsForBinary => 1,
182    );
183
184my %defines;
185my %enums;
186my %structs;
187
188say "# generated with parse_h.pl";
189for my $f (@h_files) {
190    say "# from $f";
191    parse_h($gdal_src_root . '/' . $f);
192}
193say "# end of generated code";
194
195sub parse_h {
196    my $f = shift;
197    open(my $fh, '<', $f) or die "can't open $f: $!";
198    my $s = '';
199    while (1) {
200        my $n = pre_process($fh);
201        #say STDERR "top: ",$n;
202        last unless defined $n;
203        $s .= ' '.$n;
204        next unless $s =~ /;/;
205        $s =~ s/^\s+//;
206        $s =~ s/\s+$//;
207        $s =~ tr/ //s;
208        if ($s =~ /^typedef enum/) {
209            $enums{$s} = 1;
210            $s = '';
211            next;
212        }
213        if ($s =~ /^typedef struct .*?\{/) {
214            my $struct = $s;
215            while (1) {
216                my $n = pre_process($fh);
217                die "eof while parsing typedef struct" unless defined $n;
218                # look for "} name;"
219                $struct .= ' '.$n;
220                if ($struct =~ /\} \w+;/) {
221                    last;
222                }
223            }
224            $structs{$struct} = 1;
225            $s = '';
226            next;
227        }
228        if ($s =~ /^typedef/) {
229            $s = '';
230            next;
231        }
232        if ($s =~ /^struct/) {
233            $s = '';
234            next;
235        }
236        # now $s should be a function
237        #say 'line: ',$s;
238        if ($s =~ /(\w+)\s*\((.*?)\)/) {
239            my $name = $1;
240            my $args = $2;
241            my $ret = $s;
242            $ret =~ s/$name.*//;
243            $ret = parse_type($name, $ret, 'ret');
244            my @args = split /\s*,\s*/, $args;
245            my $qw = 1;
246            for my $arg (@args) {
247                $arg = parse_type($name, $arg, 'arg');
248                $qw = 0 if $arg =~ /\s/;
249            }
250            #say "ret: $ret";
251            #say "name: $name";
252            #say "args: @args";
253            if (@args == 1 && $args[0] eq 'void') {
254                $args = '';
255            } elsif ($qw) {
256                $args = "qw/@args/";
257            } else {
258                $args = "'".join("','", @args)."'";
259            }
260            say "eval{\$ffi->attach('$name' => [$args] => '$ret');};";
261        } else {
262            die "can't parse $s as function";
263        }
264        $s = '';
265    }
266    close $fh;
267}
268
269sub parse_type {
270    my ($name, $arg, $mode) = @_;
271    $arg =~ s/^\s+//;
272    $arg =~ s/\s+$//;
273    for my $c (keys %constants) {
274        if ($arg =~ /^$c/ or $arg =~ /^const $c/) {
275            $arg = 'unsigned int';
276        }
277    }
278    for my $c (keys %callbacks) {
279        if ($arg =~ /^$c/) {
280            return $c;
281        }
282    }
283    for my $c (keys %opaque_pointers) {
284        if ($arg =~ /$c\s*\*/) {
285            return 'opaque';
286        }
287    }
288    if ($arg =~ /^\w+?H\s*\*/) {
289        if ($use_opaque_array{$name}) {
290            $arg = 'opaque[]';
291        } else {
292            $arg = 'uint64*';
293        }
294    } elsif ($arg =~ /^\w+?H/) {
295        $arg = 'opaque';
296    } elsif ($arg =~ /^const \w+?H/) {
297        $arg = 'opaque';
298    } elsif ($arg =~ /GDALColorEntry\s*\*/) {
299        $arg = 'short[4]';
300    } elsif ($arg =~ /OGREnvelope\s*\*/) {
301        $arg = 'double[4]';
302    } elsif ($arg =~ /OGREnvelope3D\s*\*/) {
303        $arg = 'double[6]';
304    } elsif ($arg =~ /GDALTriangulation/) {
305        $arg = 'opaque'; # todo: actually a record
306    } elsif ($arg =~ /^FILE\s*\*/) {
307        $arg = 'opaque';
308    } elsif ($arg =~ /void\s*\*/) {
309        for my $c (keys %use_string) {
310            if ($c eq $name) {
311                say STDERR "$name returns a string" if $mode eq 'ret' && !$ret_string_ok{$name};
312                return 'string';
313            }
314        }
315        $arg = 'opaque';
316    } elsif ($arg =~ /^char\s*\*\*/ or $arg =~ /^const char\s*\*\s*const\s*\*/) {
317        if ($use_CSL{$name}) {
318            $arg = 'opaque';
319        } else {
320            say STDERR "char ** in $name" unless $char_p_p_ok{$name};
321            $arg = 'string_pointer';
322        }
323    } elsif ($arg =~ /char\s*\*/) {
324        if ($mode eq 'ret' && $use_ret_opaque{$name}) {
325            $arg = 'opaque';
326        } else {
327            say STDERR "$name returns a string" if $mode eq 'ret' && !$ret_string_ok{$name};
328            $arg = 'string';
329        }
330    } elsif ($arg =~ /^unsigned char\s*\*/) {
331        $arg = 'pointer';
332    } elsif ($arg =~ /int\s*\*/) {
333        if ($use_array{$name}) {
334            $arg = 'int[]';
335        } elsif ($mode eq 'ret' && $use_ret_pointer{$name}) {
336            $arg = 'pointer';
337        } else {
338            $arg = 'int*';
339        }
340    } elsif ($arg =~ /^int/) {
341        $arg = 'int';
342    } elsif ($arg =~ /^unsigned int\s*\*/) {
343        $arg = 'unsigned int*';
344    } elsif ($arg =~ /^unsigned int/) {
345        $arg = 'unsigned int';
346    } elsif ($arg =~ /^long\s*\*/) {
347        $arg = 'long*';
348    } elsif ($arg =~ /^long/) {
349        $arg = 'long';
350    } elsif ($arg =~ /double\s*\*/) {
351        if ($name eq 'GDALGetGeoTransform' or $name eq 'GDALSetGeoTransform') {
352            $arg = 'double[6]';
353        } elsif ($use_array{$name}) {
354            $arg = 'double[]';
355        } elsif ($mode eq 'ret' && $use_ret_pointer{$name}) {
356            $arg = 'pointer';
357        } else {
358            $arg = 'double*';
359        }
360    } elsif ($arg =~ /^double/) {
361        $arg = 'double';
362    } elsif ($arg =~ /float\s*\*/) {
363        $arg = 'float*';
364    } elsif ($arg =~ /float/) {
365        $arg = 'float';
366    } elsif ($arg =~ /^CPLErr/) {
367        $arg = 'int';
368    } elsif ($arg =~ /^OGRErr\s*\*/) {
369        $arg = 'int*';
370    } elsif ($arg =~ /^OGRErr/) {
371        $arg = 'int';
372    } elsif ($arg =~ /^size_t/) {
373        $arg = 'size_t';
374    } elsif ($arg =~ /^const size_t/) {
375        $arg = 'size_t';
376    } elsif ($arg =~ /GByte\s*\*/) {
377        $arg = 'pointer';
378    } elsif ($arg =~ /^GUInt32\s*\*/) {
379        $arg = 'uint32*';
380    } elsif ($arg =~ /^GUInt32/) {
381        $arg = 'uint32';
382    } elsif ($arg =~ /^const GInt64\s*\*/) {
383        $arg = 'int64';
384    } elsif ($arg =~ /^GUInt64/) {
385        $arg = 'uint64';
386    } elsif ($arg =~ /^const GUInt64\s*\*/) {
387        $arg = 'uint64*';
388    } elsif ($arg =~ /^GUIntBig\s*\*/) {
389        $arg = 'uint64*';
390    } elsif ($arg =~ /^GUIntBig/) {
391        $arg = 'uint64';
392    } elsif ($arg =~ /GIntBig\s*\*/) {
393        if ($use_array{$name}) {
394            $arg = 'sint64[]';
395        } elsif ($mode eq 'ret' && $use_ret_pointer{$name}) {
396            $arg = 'pointer';
397        } else {
398            $arg = 'sint64*';
399        }
400    } elsif ($arg =~ /^GIntBig/ or $arg =~ /^GSpacing/) {
401        $arg = 'sint64';
402    } elsif ($arg =~ /^void/) {
403        $arg = 'void';
404    } elsif ($arg =~ /^CSLConstList/) {
405        $arg = 'opaque';
406    } elsif ($arg =~ /^GPtrDiff_t/) {
407        $arg = 'int';
408    } elsif ($arg =~ /^const GPtrDiff_t\s*\*/) {
409        $arg = 'int*';
410    } elsif ($arg =~ /^GDALExtendedDataTypeClass/) {
411        $arg = 'int';
412    } elsif ($arg =~ /^OSRAxisMappingStrategy/) {
413        $arg = 'int';
414    } elsif ($arg =~ /^OSRCRSInfo/) {
415        $arg = 'opaque';
416    } elsif ($arg =~ /^(const )?OSRCRSListParameters/) {
417        $arg = 'opaque';
418    } elsif ($arg =~ /^(const )?GDALMultiDimInfoOptions/) {
419        $arg = 'opaque';
420    } elsif ($arg =~ /^(const )?GDALMultiDimTranslateOptions/) {
421        $arg = 'opaque';
422    } else {
423        die "can't parse arg '$arg'";
424    }
425    return $arg;
426}
427
428sub pre_process {
429    state $skip = 0;
430    my $fh = shift;
431    while (1) {
432        my $s = '';
433        while (1) {
434            my $n = get_line($fh);
435            #say STDERR "got: ",$n;
436            return if !defined($n) && $s eq '';
437            return $s unless defined $n;
438            $s .= ' '.$n;
439            last unless $s =~ /\\$/;
440        }
441        $s =~ s/^\s+//;
442        $s =~ s/\s+$//;
443        $s =~ tr/ //s;
444        $s =~ s/^#\s+/#/;
445        if ($s =~ /^#ifndef (\w+)/) {
446            next;
447        }
448        if ($s =~ /^#ifdef (\w+)/ or $s =~ /^#if defined\((\w+)\)/) {
449            if (
450                $1 eq 'DEBUG'
451                or $1 eq 'undef'
452                or $1 eq 'GDAL_COMPILATION'
453                or $1 eq 'USE_DEPRECATED_SRS_WKT_WGS84'
454                ) {
455                $skip = 1;
456                next;
457            }
458        }
459        if ($s =~ /^#else/) {
460            $skip = 0 if $skip;
461            next;
462        }
463        if ($s =~ /^#define (\w+) (.*)/) {
464            $defines{$1} = $2;
465            next;
466        }
467        # skip all other defines
468        if ($s =~ /^#define/) {
469            next;
470        }
471        if ($s =~ /^#include/) {
472            next;
473        }
474        if ($s =~ /^#endif/) {
475            $skip = 0 if $skip;
476            next;
477        }
478        next if $skip;
479        return $s;
480    }
481}
482
483sub get_line {
484    state $state = '';
485    my $fh = shift;
486    my $s = <$fh>;
487    return unless $s;
488    chomp $s;
489    #say STDERR 'line: ',$s;
490    if ($state eq 'comment') {
491        if ($s =~ /\*\//) {
492            $s =~ s/.*?\*\///;
493            $state = '';
494        } else {
495            return '';
496        }
497    }
498    # replace pre-defined constants
499    for my $def (keys %pre) {
500        $s =~ s/$def/$pre{$def}/;
501    }
502    # remove on-line comments
503    if ($s =~ /\/\*/ and $s =~ /\*\//) {
504        $s =~ s/\/\*.*?\*\///;
505    }
506    $s =~ s/\/\/.*//;
507    # remove starting comment and set state
508    if ($s =~ /\/\*/) {
509        $s =~ s/\/\*.*//;
510        $state = 'comment';
511    }
512    return $s;
513}
514