Flesh out vkheader implementation, uses registry and custom callbacks to fill out...
[panamaz] / src / notzed.nativez / lib / api.pm
1
2 # TODO: define more & consistent stage processing hooks, currently implicit require init() and stage.postprocess
3 # TODO: code:<inline> etc should probably instead be code:<type> where <type> is one of the template fields - methods, init, etc.
4
5 package api;
6
7 use strict;
8
9 use File::Path qw(make_path);
10 use File::Basename;
11 use Data::Dumper;
12 use List::Util qw(first);
13 use Carp 'verbose';
14
15 use config;
16
17 my %renameTable = (
18         'studly-caps' => sub { my $s = shift; $s =~ s/(?:^|_)(.)/\U$1/g; return $s; },
19         'camel-case' => sub { my $s = shift; $s =~ s/(?:_)(.)/\U$1/g; return $s; },
20         'upper-leadin' => sub { my $s = shift; $s =~ s/^([^_]+)/\U$1/; return $s; },
21         'identity' => sub {     return $_[0]; },
22         'call' => sub {
23                 my $s = shift;
24
25                 if ($s =~ m/\(/) {
26                         $s =~ s/u32:|u64:/p/g;
27                         $s =~ s/\$\{([^\}]+)\}/$1/g;
28                         $s =~ s/[\(\)]/_/g;
29                         $s =~ s/^/Call/;
30                 }
31                 $s;
32         }
33 );
34
35 my %defaultTable = (
36         'struct:<default>' => {
37                 name => '<default>',
38                 items => [],
39                 options => [ 'default=none', 'access=rw', 'field:rename=studly-caps' ],
40                 regex => qr/^struct:<default>$/,
41                 type => 'struct'
42         },
43         'union:<default>' => {
44                 name => '<default>',
45                 items => [],
46                 options => [ 'default=all', 'access=rw', 'field:rename=studly-caps' ],
47                 regex => qr/^union:<default>$/,
48                 type => 'union'
49         },
50         'call:<default>' => {
51                 name => '<default>',
52                 items => [],
53                 options => [ 'call:rename=call', 'access=r' ],
54                 regex => qr/^call:<default>$/,
55                 type => 'call'
56         },
57         'func:<default>' => {
58                 name => '<default>',
59                 items => [],
60                 options => [],
61                 regex => qr/^func:<default>$/,
62                 type => 'func',
63                 'func:template' => 'code:method=invoke'
64         },
65         'enum:<default>' => {
66                 name => '<default>',
67                 items => [],
68                 options => [],
69                 regex => qr/^enum:<default>$/,
70                 type => 'enum'
71         },
72 );
73
74 sub new {
75         my $class = shift;
76         my $file = shift;
77         my $vars = shift;
78         my $self = {
79                 vars => $vars,
80                 index => {},
81                 data => {},
82                 types => [],
83         };
84
85         my $conf = new config($vars, $file);
86         $self->{api} = $conf->{objects};
87         foreach my $obj (@{$self->{api}}) {
88                 $self->{index}->{"$obj->{type}:$obj->{name}"} = $obj;
89         }
90         foreach my $k (keys %defaultTable) {
91                 if (!defined($self->{index}->{$k})) {
92                         $self->{index}->{$k} = $defaultTable{$k};
93                         push @{$self->{api}}, $defaultTable{$k};
94                 }
95         }
96
97         while ($#_ >= 0) {
98                 my $name = shift;
99                 my $info = loadAPIFile($name);
100
101                 $self->{data} = { %{$self->{data}}, %{$info} };
102         }
103
104         # FIXME: fix the list names in export.cc and export-defines instead
105         # set all the member list names to be consistent
106         foreach my $s (values %{$self->{data}}) {
107                 foreach my $n ('fields', 'arguments', 'values') {
108                         if ($s->{$n}) {
109                                 $s->{items} = $s->{$n};
110                                 delete $s->{$n};
111                         }
112                 }
113         }
114
115         bless $self, $class;
116
117         # handle requires and init modules
118         foreach my $p (@{$conf->{pragmas}}) {
119                 if ($p->[0] eq '%require') {
120                         require $p->[1];
121                         my $n = $p->[1];
122                         $n =~ s/.pm$/::init(\$self)/;
123                         print "$n\n";
124                         eval $n || die "module init failed: $! $@";
125                 }
126         }
127
128         analyseAPI($self);
129         preprocess($self);
130
131         # add phantom 'api' entries for anything else required
132         foreach my $s (findDependencies($self)) {
133                 my $n = "$s->{type}:$s->{name}";
134                 my $def = $self->{index}->{"$s->{type}:<default>"};
135
136                 die "no default for implicit dependency $n" if (!$def);
137
138                 my $obj = {
139                         %$def,
140                         match => "$s->{type}:$s->{name}",
141                         name => $s->{name},
142                         regex => qr/^$n$/,
143                 };
144                 $obj->{rename} = $obj->{"$obj->{type}:rename"} ? $obj->{"$obj->{type}:rename"}->($obj->{name}) : $obj->{name};
145
146                 print " implicit $n\n";
147                 push @{$self->{api}}, $obj;
148                 $self->{index}->{$n} = $obj;
149         }
150
151         postprocess($self);
152
153         foreach my $p (@{$conf->{pragmas}}) {
154                 if ($p->[0] eq '%stage.postprocess') {
155                         eval "$p->[1](\$self)" || die "$p->[0] $p->[1] failed: $! $@";
156                 }
157         }
158
159         # form the types
160         # TODO: could match the regexes to every possible type in the api and create a direct index
161         my $copyIndex = {};
162         foreach my $obj (grep { $_->{type} eq 'type' && $_->{name} =~ m@<.*>@ } @{$self->{api}}) {
163                 $copyIndex->{$obj->{name}} = $obj;
164         }
165
166         foreach my $obj (grep { $_->{type} eq 'type' && $_->{name} =~ m@^/.*/$@ } @{$self->{api}}) {
167                 push @{$self->{types}}, initType($self, $copyIndex, $obj);
168         }
169
170         return $self;
171 }
172
173 # class.name to class/name.java
174 sub classToPath {
175         my $api = shift;
176         my $name = shift;
177
178         $name = $api->{vars}->{package}.'.'.$name;
179         $name =~ s@\.@/@g;
180         $name = $api->{vars}->{output}.'/'.$name.'.java';
181         $name;
182 }
183
184 sub closeOutput {
185         my $api = shift;
186         my $name = shift;
187         my $f = shift;
188         my $path = $api->classToPath($name);
189
190         close($f) || die;
191         rename($path.'~', $path) || die ("rename failed: $!");
192 }
193
194 sub openOutput {
195         my $api = shift;
196         my $name = shift;
197         my $path = $api->classToPath($name);
198         my $dir = dirname($path);
199
200         make_path($dir) if (!-d $dir);
201
202         open(my $f, ">", $path.'~') || die ("Cannot open '$path' for writing");
203         #print "writing '$path'\n";
204         $f;
205 }
206
207 sub renameFunction {
208         my $api = shift;
209         my $name = shift;
210         $renameTable{$name};
211 }
212
213 sub initType {
214         my $api = shift;
215         my $index = shift;
216         my $obj = shift;
217         my $type = {};
218
219         $type->{options} = [ @{$obj->{options}} ];
220         $type->{file} = $obj->{file};
221
222         # FIXME: per-item options, set etc?
223         foreach my $inc (grep { defined $_->{literal} } @{$obj->{items}}) {
224                 $type->{items}->{$inc->{match}} = $inc->{literal};
225         }
226
227         my $v = optionValue('select', undef, $obj);
228         $type->{select} = $v if defined($v);
229
230         #print "init $obj->{name}\n";
231         foreach my $c (split /,/,optionValue('copy', undef, $obj)) {
232                 my $copy = $index->{$c};
233
234                 if ($copy) {
235                         #print " copy $c\n";
236                         my $proto = initType($api, $index, $copy);
237
238                         foreach my $k (keys %{$proto->{items}}) {
239                                 $type->{items}->{$k} = $proto->{items}->{$k} if !defined($type->{items}->{$k});
240                         }
241
242                         push @{$type->{options}}, @{$proto->{options}};
243                 } else {
244                         die ("type copy target $c not found");
245                 }
246         }
247
248         $type->{regex} = qr/$1/ if $obj->{name} =~ m@/(.*)/@;
249
250         return $type;
251 }
252
253 # returns { type=>$type, match=>$match)
254 #  match is named groups from regex (%+)
255 sub findType {
256         my $api = shift;
257         my $m = shift;
258         my $deref = $m->{deref};
259         my @list;
260
261         foreach my $type (@{$api->{types}}) {
262                 my $select = !defined($type->{select}) || defined($m->{select}->{$type->{select}});
263
264                 if ($select && ($deref =~ m/$type->{regex}/)) {
265                         my %match = %+;
266
267                         return { deref=>$deref, type=>$type, match=>\%match };
268                 }
269         }
270         die ("cannot find matching type '$deref' for member $m->{name}");
271         undef;
272 }
273
274 sub findTemplateName {
275         my $api = shift;
276         my $name = shift;
277
278         if ($name =~ m/^(.+)=(.+)$/) {
279                 my $template = findItem($api->{index}->{$1}, $2);
280                 return $template if defined $template;
281         }
282         die "can't find template '$name'\n";
283 }
284
285 sub queryTemplate {
286         my $api = shift;
287         my $obj = shift;
288         my $s = shift;
289         my $sname = $s->{"$s->{type}:template"};
290         my $def = $api->{index}->{"$s->{type}:<default>"};
291         my $name = $sname ? $sname : api::optionValue('template', $s->{size} == 0 ? 'code:class=handle' : 'code:class=struct', $obj, $def);
292
293         return $name;
294 }
295
296 sub findTemplate {
297         my $api = shift;
298         my $obj = shift;
299         my $s = shift;
300         my $sname = $s->{"$s->{type}:template"};
301         my $def = $api->{index}->{"$s->{type}:<default>"};
302         my $name = $sname ? $sname : api::optionValue('template', $s->{size} == 0 ? 'code:class=handle' : 'code:class=struct', $obj, $def);
303
304         print "template: $s->{name} -> $name\n" if ($api->{vars}->{verbose} > 1);
305
306         return findTemplateName($api, $name);
307 }
308
309 # find value of first option of the given name
310 sub optionValue {
311         my $name = shift;
312         my $or = shift;
313
314         #print "optionValue $name\n";
315         foreach my $obj (@_) {
316                 foreach my $opt (@{$obj->{options}}) {
317                         #print "? $name $opt = ".($opt =~m/^\Q$name\E=(.*)$/)."\n";
318                         #print " = $opt\n" if ($opt =~m/^\Q$name\E=(.*)$/);
319                         return $1 if ($opt =~m/^\Q$name\E=(.*)$/);
320                 }
321         }
322         $or;
323 }
324
325 # look for all matching options of the given name
326 # multiple objects are searched, the first one with
327 #  the given parameter overrides the rest.
328 # name, object, object *
329 sub optionValues {
330         my $name = shift;
331         my $rx = qr/$name/;
332         my @list;
333
334         foreach my $obj (@_) {
335                 foreach my $opt (@{$obj->{options}}) {
336                         push @list, $1 if ($opt =~m/^$rx=(.*)$/);
337                 }
338                 last if ($#list >= 0);
339         }
340         @list;
341 }
342
343 # same as above but doesn't short-circuit
344 sub optionValuesAll {
345         my $name = shift;
346         my $rx = qr/$name/;
347         my @list;
348
349         foreach my $obj (@_) {
350                 foreach my $opt (@{$obj->{options}}) {
351                         push @list, $1 if ($opt =~m/^$rx=(.*)$/);
352                 }
353         }
354         @list;
355 }
356
357 # find first occurance of a flag
358 sub optionFlag {
359         my $name = shift;
360
361         foreach my $obj (@_) {
362                 foreach my $opt (@{$obj->{options}}) {
363                         return 1 if ($opt eq $name);
364                 }
365         }
366         undef;
367 }
368
369 sub findItem {
370         my $s = shift;
371         my $name = shift;
372
373         foreach my $i (@{$s->{items}}) {
374                 return $i if $i->{match} eq $name;
375         }
376         undef;
377 }
378
379 sub findAllItems {
380         my $api = shift;
381         my $obj = shift;
382         my $s = shift;
383         my %visited = ();
384         my @fields = ();
385
386         #print Dumper($obj);
387
388         my @all = @{$s->{items}};
389         my %index;
390
391         foreach my $m (@all) {
392                 $index{$m->{name}} = $m;
393         }
394
395         foreach my $inc (@{$obj->{items}}) {
396                 my $d = $index{$inc->{match}};
397
398                 if ($d) {
399                         next if $visited{$d->{type}.':'.$d->{name}}++;
400                         push @fields, [ $inc, $d ];
401                 } else {
402                         foreach my $d (grep { $_->{name} =~ m/$inc->{regex}/ } @all) {
403                                 next if $visited{$d->{type}.':'.$d->{name}}++;
404                                 push @fields, [ $inc, $d ];
405                         }
406                 }
407         }
408
409         if (optionValue('default', undef, $obj, $api->{index}->{'struct:<default>'}) eq 'all') {
410                 #print "* add all items\n";
411                 foreach my $d (@all) {
412                         next if $visited{$d->{type}.':'.$d->{name}}++;
413                         push @fields, [ $obj, $d ];
414                 }
415         }
416
417         return @fields;
418 }
419
420 sub findField {
421         my $s = shift;
422         my $name = shift;
423
424         foreach my $i (@{$s->{items}}) {
425                 return $i if $i->{name} eq $name;
426         }
427         undef;
428 }
429
430 # ######################################################################
431
432 sub addDependencies {
433         my $api = shift;
434         my $obj = shift;
435         my $s = shift;
436         my $add = shift;
437
438         #print "add deps for '$s->{name}'\n";
439         if ($s->{type} =~ m/^(struct|union)$/n) {
440                 # include embedded structures always
441                 foreach my $d (grep { $_->{type} =~ m/^(struct|union):/ && $_->{deref} =~ m/\[\d+\$\{|^\$\{/ } @{$s->{items}}) {
442                         #print "  embedded $d->{name} $d->{deref}\n";
443                         $add->($d->{type});
444                 }
445
446                 # include selected fields optionally
447                 if ($obj) {
448                         foreach my $i (findAllItems($api, $obj, $s)) {
449                                 my ($inc, $d) = @{$i};
450                                 #print "  selected $d->{name} $d->{type} $d->{deref}\n";
451                                 $add->($d->{type}) if ($d->{type} =~ m/^(struct|union|func|call|enum):/);
452                                 # HACK: enum types are integers but ctype includes the actual type
453                                 $add->("enum:$1") if ($d->{ctype} =~ m/^enum (.+)/);
454                         }
455                 }
456         } elsif ($s->{type} =~ m/^(call|func)/n) {
457                 # for calls/func need all fields
458                 foreach my $d (grep { $_->{type} =~ m/^(struct|union|func|call|enum):/ } @{$s->{items}}, $s->{result}) {
459                         #print "  argument $d->{name} $d->{type} $d->{deref}\n";
460                         $add->($d->{type});
461                 }
462         }
463 }
464
465 # use either {match} or {regex} or {matcher} to get all matches for a data type
466 sub findMatches {
467         my $api = shift;
468         my $inc = shift;
469         my $ctx = shift;
470         my $data = $api->{data};
471
472         if ($inc->{matcher}) {
473                 grep { $inc->{matcher}->($_, $ctx) } grep { $_->{type} eq $inc->{type} } values %$data;
474         } else {
475                 my $s = $data->{$inc->{match}};
476
477                 if (defined($s)) {
478                         $s;
479                 } else {
480                         map { $data->{$_} } grep { $_ =~ m/$inc->{regex}/ } keys %$data;
481                 }
482         }
483 }
484
485 # find all extra types used by the api requested
486 sub findDependencies {
487         my $api = shift;
488         my %data = %{$api->{data}};
489         my %seen;
490         my %deps;
491         my $setdeps = sub { my $d = shift; $deps{$d} = 1; };
492
493         print "Root types\n";
494         foreach my $obj (@{$api->{api}}) {
495                 if ($obj->{type} eq 'library') {
496                         foreach my $inc (@{$obj->{items}}) {
497                                 next if ($inc->{type} eq 'library');
498
499                                 print "? $inc->{match}\n";
500                                 foreach my $s (findMatches($api, $inc, $obj)) {
501                                         my $n = "$s->{type}:$s->{name}";
502
503                                         print "+ $n\n";
504
505                                         $seen{$n}++;
506                                         $s->{output} = 1;
507                                         addDependencies($api, $obj, $s, $setdeps);
508                                 }
509                         }
510                 } elsif ($obj->{type} =~ m/^(struct|union|call|func|enum|define)$/) {
511                         #foreach my $n (grep { $_ =~ m/$obj->{regex}/ } keys %data) {
512
513                         print "? $obj->{name}\n";
514
515
516                         foreach my $s (findMatches($api, $obj, $obj)) {
517                                 my $n = "$s->{type}:$s->{name}";
518
519                                 print "+ $n\n";
520
521                                 $seen{$n}++;
522                                 $s->{output} = 1;
523                                 addDependencies($api, $obj, $s, $setdeps);
524                         }
525                 }
526         }
527
528         # at this point 'seen' contains everything explicitly requested
529         # and deps is anything else they need but not referenced directly
530         # recursively grab anything else
531
532         my @list = ();
533         my @stack = sort keys %deps;
534         my $pushstack = sub { my $d = shift; push @stack, $d; };
535         while ($#stack >= 0) {
536                 my $n = shift @stack;
537                 my $s;
538
539                 next if $seen{$n}++;
540
541                 $s = $data{$n};
542
543                 if ($s) {
544                         print "Add referent: $n\n";
545                         $s->{output} = 1;
546                         addDependencies($api, $api->{index}->{"$s->{type}:<default>"}, $s, $pushstack);
547                 } elsif ($n =~ m/^(.*):(.*)$/) {
548                         print "Add anonymous: $n\n";
549                         # type not know, add anonymous
550                         $s = {
551                                 name => $2,
552                                 type => $1,
553                                 size => 0,
554                                 items => [],
555                                 output => 1,
556                         };
557                         $api->{data}->{$n} = $s;
558                 }
559
560                 # maybe it should have some skeleton metadata?
561                 # depends on where it's used i suppose
562                 push @list, $s;
563         }
564
565         print "Added ".($#list+1)." dependencies\n";
566         return @list;
567 }
568
569 # ######################################################################
570
571 sub loadAPIFile {
572         my $file = shift;
573         my $info;
574
575         unless ($info = do $file) {
576                 die "couldn't parse $file: $@"  if $@;
577                 die "couldn't import $file: $!" unless defined $info;
578                 die "couldn't run $file"                unless $info;
579         }
580
581         return $info;
582 }
583
584 sub parseRename {
585         my $api = shift;
586         my $how = shift;
587         my $rename = $renameTable{'identity'};
588
589         foreach my $n (split /,/,$how) {
590                 my $old = $rename;
591                 my $new = $renameTable{$n};
592
593                 if ($n =~ m@^s/(.*)/(.*)/$@) {
594                         my $rx = qr/$1/;
595                         my $rp = $2;
596                         $rename = sub { my $s=shift; $s = $old->($s); $s =~ s/$rx/$rp/; return $s;};
597                 } elsif ($n =~ m@^func:(.*)$@) {
598                         $rename = eval "sub { $1(\@_) }";
599                         if (!defined($rename)) {
600                                 die "Unable to parse rename function '$1'";
601                         }
602                 } elsif ($new) {
603                         $rename = sub { my $s=shift; $s = $old->($s); return $new->($s); };
604                 } else {
605                         my $x = $n;
606                         $rename = sub { return $x; };
607                 }
608         }
609         $rename;
610 }
611
612 # pre-process {data}
613 sub preprocess {
614         my $api = shift;
615
616         # Find any anonymous types and add them in
617         my %anonymous = ();
618         foreach my $s (values %{$api->{data}}) {
619
620                 foreach my $m (grep { $_->{type} =~ m/struct:|union:/} @{$s->{items}}) {
621                         $anonymous{$m->{type}} = 1 if !defined($api->{data}->{$m->{type}});
622                 }
623
624                 # add 'result' name
625                 $s->{result}->{name} = 'result$' if $s->{type} =~ m/func|call/;
626
627                 # add a canonical deref for all types
628                 if ($s->{type} =~ m/func|call|struct|union/) {
629                         foreach my $m (grep { !defined($_->{deref}) } @{$s->{items}}, ($s->{type} =~ m/func|call/) ? $s->{result} : ()) {
630                                 if ($m->{type} =~ m/^(union|struct):(.*)/) {
631                                         $m->{deref} = "\${$2}";
632                                 } elsif ($m->{ctype} eq 'bitfield') {
633                                         $m->{deref} = "bitfield";
634                                 } else {
635                                         $m->{deref} = $m->{type};
636                                 }
637                         }
638                 }
639
640                 # all 'defines' are output by default
641                 $s->{output} = 1 if $s->{type} eq 'define';
642         }
643
644         foreach my $k (sort keys %anonymous) {
645                 print " anon $k\n";
646                 if ($k =~ m/^(.*):(.*)$/) {
647                         $api->{data}->{$k} = {
648                                 name => $2,
649                                 type => $1,
650                                 size => 0,
651                                 items => [],
652                         };
653                 }
654         }
655 }
656
657 # preprocess {api}
658 sub analyseAPI {
659         my $api = shift;
660
661         # Note that type:name regexes always start at the beginning
662
663         foreach my $obj (@{$api->{api}}) {
664                 $obj->{match} = "$obj->{type}:$obj->{name}";
665
666                 if ($obj->{name} =~ m@^/(.*)/$@) {
667                         $obj->{regex} = qr/^$obj->{type}:$1/;
668                 } elsif ($obj->{name} =~ m@^<invoke=(.*)>$@) {
669                         $obj->{matcher} = eval "sub { $1(\@_) }";
670                         die "unable to parse match function $obj->{name} $! $@" if !defined($obj->{matcher});
671                 } else {
672                         $obj->{regex} = qr/^$obj->{type}:$obj->{name}$/;
673                 }
674
675                 foreach my $opt (@{$obj->{options}}) {
676                         if ($opt =~ m/^(.+:rename)=(.*)$/) {
677                                 $obj->{$1} = parseRename($api, $2);
678                         } elsif ($opt =~ m/^rename=(.*)$/) {
679                                 $obj->{"$obj->{type}:rename"} = parseRename($api, $1);
680                         }
681                 }
682
683                 my $defmode = ($obj->{type} eq 'library' ? 'func' : 'field');
684                 foreach my $inc (@{$obj->{items}}) {
685                         my $match = $inc->{match};
686                         my $mode = $defmode;
687
688                         if ($inc->{match} =~ m/^(.*?):(.*)$/) {
689                                 $match = $2;
690                                 $mode = $1;
691                         }
692
693                         $inc->{type} = $mode;
694                         if ($match =~ m@^/(.*)/$@) {
695                                 $inc->{regex} = $mode ne 'field' ? qr/$mode:$1/ : qr/$1/;
696                         } elsif ($match =~ m@^<invoke>$@) {
697                                 $inc->{matcher} = eval "sub { $inc->{literal} }";
698                                 die "unable to parse match function $inc->{literal} $! $@" if !defined($inc->{matcher});
699                         } elsif ($match =~ m@^<invoke=(.*)>$@) {
700                                 $inc->{matcher} = eval "sub { $1(\@_) }";
701                                 die "unable to parse match function $inc->{match} $! $@" if !defined($inc->{matcher});
702                         } else {
703                                 $inc->{regex} = $mode ne 'field' ? qr/^$mode:$match$/ : qr/^$match$/;
704                         }
705
706                         foreach my $opt (@{$inc->{options}}) {
707                                 if ($opt =~ m/^rename=(.*)$/) {
708                                         #print "option $opt ".Dumper($inc);
709                                         $inc->{"$mode:rename"} = parseRename($api, $1);
710                                 }
711                         }
712
713                         $inc->{"$mode:rename"} = $obj->{"$mode:rename"} if (!(defined($inc->{"$mode:rename"})) && defined($obj->{"$mode:rename"}));
714                 }
715         }
716 }
717
718 #
719 # 'lib/struct/func' level    'lib.inc' level            'func/struct.inc' level  setting
720 #  array:name1                array:name1                array                    char* is array, void* is a Segment
721 #  array-size:name1=name2     array-size:name1=name2     array-size=name2         implied array size from name2
722 #  implied:name1=expr         implied:name1=expr         implied=expr             value of name1 is calculated from other arguments
723 #  instance:name1             instance:name1             instance                 parameter/return is instance, implies non-static function
724
725 #  scope:name1=scope[,close]  scope:name1=scope[,close]  scope=scope[,close]      parameter/return is a new instance with given scope
726 #  success:name1=values       success:name1=values       success=values           which parameter and values indicate integer success
727 #                                                                                 pointer types are considered in/out and implied
728 #  success:name1=!null        success:name1=!null        success=!null            which parameter and values indicate non-null success
729 #  return:name1               return:name1               return                   return this output argument instead of the return code
730
731 #  access:name1=rwi           access:name1=rwi           access=rwi               set access type, read, write, indexed
732 #  access=rwi                 access=rwi                 access=rwi                - can also be set as default
733
734 #  onsuccess=blah             onsuccess=blah             onsuccess=blah
735
736 # 'name' is parameter name, or parameter index, or result$ for return value
737 # scope is instance for instance-scope, explicit for explicit scope, global for global scope.  default is global.
738
739 # err, maybe this format makes more sense:
740 #   name1:success=values   name1:success=values  success=values
741 #   name1:instance         name1:instance        instance
742
743 my @itemFlags = (
744         'array',
745         'segment',
746         'instance',
747         'return',
748         'raw',
749         'raw-in',
750 );
751
752 my @itemOptions = (
753         'array-size',
754         'scope',
755         'success',
756         'implied',
757         'tonative',
758 );
759
760 my @itemAnyOptions = (
761         'access',
762 );
763
764 # process struct->field
765 #  api, obj (struct, func), inc (field entry), s (struct), m (struct field)
766 # Note: keep in sync with processFunc
767 sub processField {
768         my $api = shift;
769         my $obj = shift;
770         my $inc = shift;
771         my $s = shift;
772         my $m = shift;
773         my $def = $api->{index}->{"$s->{type}:<default>"};
774
775         #print "process $s->{type}:$s->{name}.$m->{name}\n";
776         print "  $m->{name}\n" if ($api->{vars}->{verbose} > 1);
777
778         foreach my $flag (@itemFlags) {
779                 my $value = optionFlag("$flag", $inc);
780                 $value = optionFlag("$flag:$m->{name}", $obj, $def) if !defined($value);
781                 $m->{$flag} = $value if (defined($value));
782                 $m->{select}->{$flag} = 1 if (defined($value));
783         }
784         foreach my $option (@itemOptions) {
785                 my $value = optionValue("$option", undef, $inc);
786                 $value = optionValue("$option:$m->{name}", undef, $obj, $def) if !defined($value);
787                 $m->{$option} = $value if (defined($value));
788                 $m->{select}->{$option} = 1 if (defined($value));
789         }
790         foreach my $option (@itemAnyOptions) {
791                 my $value = optionValue("$option", undef, $inc);
792                 $value = optionValue("$option:$m->{name}", undef, $obj, $def) if !defined($value);
793                 $value = optionValue("$option", undef, $obj, $def) if !defined($value);
794                 $m->{$option} = $value if (defined($value));
795         }
796
797         $m->{output} = 1;
798         $m->{rename} = (first { defined $_ } $inc->{'field:rename'}, $obj->{'field:rename'}, $def->{'field:rename'}, $renameTable{identity})->($m->{name}, $m, $s);
799 }
800
801 # process func or call main type
802 sub processTypeFunc {
803         my $api = shift;
804         my $seen = shift;
805         my $obj = shift;
806         my $def = $api->{index}->{"$obj->{type}:<default>"};
807
808         foreach my $s (@_) {
809                 my $v;
810
811                 if ($seen->{"$s->{type}:$s->{name}"}++) { print "warning: seen $s->{type}:$s->{name}\n"; next; }
812
813                 print " $s->{name}\n" if ($api->{vars}->{verbose} > 1);
814
815                 foreach my $m ($s->{result}, @{$s->{items}}) {
816                         my $inc = findItem($obj, $m->{name});
817
818                         processField($api, $obj, $inc, $s, $m);
819                 }
820
821                 $s->{rename} = (first { defined $_ } $obj->{"$s->{type}:rename"}, $renameTable{identity})->($s->{name}, $s);
822                 $s->{access} = optionValue('access', '', $obj, $def);
823                 $v = optionValue('onsuccess', undef, $obj, $def);
824                 $s->{onsuccess} = $v if defined $v;
825
826                 postProcessType($s);
827         }
828 }
829
830 # process library->func
831 # process struct->func
832 #  api, obj (library, struct), inc (func entry), s ($data->{func:name})
833 # Note: keep in sync with processField
834 sub processFunc {
835         my $api = shift;
836         my $obj = shift;
837         my $inc = shift;
838         my $s = shift;
839         my @params = (defined($s->{result}) ? $s->{result} : (), @{$s->{items}});
840         my $index = -1;
841         my $lindex = -2 - $#params;
842         my $def = $api->{index}->{"$s->{type}:<default>"};
843         my $v;
844
845         print "process $s->{type}:$s->{name}\n" if ($api->{vars}->{verbose} > 1);
846
847         foreach my $m (defined($s->{result}) ? $s->{result} : (), @{$s->{items}}) {
848                 #print "[$index] [$lindex] $m->{name}\n";
849
850                 foreach my $flag (@itemFlags) {
851                         my $value = optionFlag("$flag:$m->{name}", $inc, $obj, $def);
852                         $value = optionFlag("$flag:$index", $inc, $obj, $def) if !defined($value);
853                         $value = optionFlag("$flag:$lindex", $inc, $obj, $def) if !defined($value);
854                         $m->{$flag} = $value if (defined($value));
855                         $m->{select}->{$flag} = 1 if (defined($value));
856                 }
857                 foreach my $option (@itemOptions) {
858                         my $value = optionValue("$option:$m->{name}", undef, $inc, $obj, $def);
859                         $value = optionValue("$option:$index", undef, $inc, $obj, $def) if !defined($value);
860                         $value = optionValue("$option:$lindex", undef, $inc, $obj, $def) if !defined($value);
861                         $m->{$option} = $value if (defined($value));
862                         $m->{select}->{$option} = 1 if (defined($value));
863                 }
864                 foreach my $option (@itemAnyOptions) {
865                         my $value = optionValue("$option:$m->{name}", undef, $inc, $obj, $def);
866                         $value = optionValue("$option:$index", undef, $inc, $obj, $def) if !defined($value);
867                         $value = optionValue("$option:$lindex", undef, $inc, $obj, $def) if !defined($value);
868                         $value = optionValue("$option", undef, $inc, $obj, $def) if !defined($value);
869                         $m->{$option} = $value if (defined($value));
870                 }
871                 $m->{output} = 1;
872                 $index++;
873                 $lindex++;
874         }
875
876         $s->{rename} = (first { defined $_ } $inc->{"$s->{type}:rename"}, $obj->{"$s->{type}:rename"}, $renameTable{identity})->($s->{name}, $s);
877         $s->{access} = optionValue('access', '', $inc, $obj, $def);
878         $v = optionValue('onsuccess', undef, $inc, $obj, $def);
879         $s->{onsuccess} = $v if defined ($v);
880
881         postProcessType($s);
882 }
883
884 # finally link up array sizes and work out what is output or not
885 # TODO: struct field array-size should be output but not included in constructors?
886 sub postProcessType {
887         my $s = shift;
888         my $static = 1;
889
890         foreach my $m (defined($s->{result}) ? $s->{result} : (), @{$s->{items}}) {
891                 $static = 0 if ($m->{instance});
892
893                 # FIXME: collect multiple scopes here
894                 $s->{scope} = 'explicit' if ($m->{scope} =~ m/^explicit$|^explicit,(.*)$/);
895                 $s->{scope} = 'global' if ($m->{scope} eq 'global');
896                 $s->{scope} = 'object' if ($m->{scope} eq 'object');
897
898                 if ($m->{'array-size'}) {
899                         my $size = findField($s, $m->{'array-size'});
900
901                         print Dumper($s) if (!defined($size));
902                         die "can't find array-size=$m->{'array-size'}" if !defined($size);
903
904                         $size->{output} = 0 if ($s->{type} =~ m/func|call/);
905                         $size->{'array-size-source'} = $m;
906                         $m->{'array-size'} = $size;
907                 }
908
909                 # no java arg for instance parameter
910                 $m->{output} = 0 if ($m->{instance});
911                 # don't generate java args for values calculated
912                 $m->{output} = 0 if (defined($m->{implied}));
913                 # don't generate java args for return statuss unless they're also the constructed value
914                 $m->{output} = 0 if (defined($m->{success}) && !$m->{scope});
915                 # don't generate java args for output arguments
916                 $m->{output} = 0 if ($m->{scope} && $m->{name} ne 'result$');
917
918                 # link success/return fields to struct/func
919                 $s->{success} = $m if defined($m->{success});
920                 $s->{return} = $m if ($m->{return});
921         }
922
923         $s->{static} = $static;
924
925         # TODO: default scope?  or from struct:<default> etc?
926 }
927
928 # transfer info from {api} to {data}
929 sub processFields {
930         my $api = shift;
931         my $seen = shift;
932         my $obj = shift;
933         my $inc = shift;
934         my $s = shift;
935
936         foreach my $m (@_) {
937                 next if $seen->{$m->{name}}++;
938
939                 processField($api, $obj, $inc, $s, $m);
940         }
941 }
942
943 # process a struct/union
944 # these have fields as well as potentially other included types
945 sub processType {
946         my $api = shift;
947         my $seen = shift;
948         my $obj = shift;
949         my $def = $api->{index}->{"$obj->{type}:<default>"};
950
951         foreach my $s (@_) {
952                 my $memberseen = {};
953
954                 next if ($seen->{"$s->{type}:$s->{name}"}++);
955
956                 print "process type $obj->{match} $s->{type}:$s->{name}\n" if ($api->{vars}->{verbose} > 1);
957
958                 # process the struct/union fields first
959                 foreach my $inc (grep { $_->{type} eq 'field' } @{$obj->{items}}) {
960                         my @list = grep { $_->{name} =~ m/$inc->{regex}/ } @{$s->{items}};
961
962                         processFields($api, $memberseen, $obj, $inc, $s, @list);
963                 }
964
965                 if (optionValue('default', undef, $obj, $def) eq 'all') {
966                         print " + adding all fields\n" if ($api->{vars}->{verbose} > 1);
967                         processFields($api, $memberseen, $obj, undef, $s, @{$s->{items}});
968                 }
969
970                 $s->{rename} = (first { defined $_ } $obj->{"$s->{type}:rename"}, $def->{"$s->{type}:rename"}, $renameTable{identity})->($s->{name}, $s);
971
972                 # finish off
973                 postProcessType($s);
974
975                 # handle other types included/mark them no-output
976                 #$seen->{"$s->{type}:$s->{name}"} = 0;
977                 processLibrary($api, $seen, $obj, $s);
978         }
979
980 }
981
982 sub processLibrary {
983         my $api = shift;
984         my $seen = shift;
985         my $lib = shift;
986         my $ctx = shift;
987         my $data = $api->{data};
988
989         #return if ($seen->{"$ctx->{type}:$ctx->{name}"}++);
990
991         print "process library $ctx->{type}:$ctx->{name}\n" if ($api->{vars}->{verbose} > 0);
992         #print 'lib='.Dumper($lib);
993         #print Dumper($api->{api}); die;
994         #print 'lib.options='.Dumper($lib->{options});
995
996         # TODO: embedded types
997
998         foreach my $inc (@{$lib->{items}}) {
999                 print " $inc->{match}\n" if ($api->{vars}->{verbose} > 1);
1000
1001                 if ($inc->{type} =~ m/func|call/on) {
1002                         my @list = findMatches($api, $inc, $ctx);
1003
1004                         #print 'inc='.Dumper($inc);
1005                         #print "match $inc->{regex} .options=".Dumper($inc->{options});
1006
1007                         foreach my $s (@list) {
1008                                 if ($seen->{"$s->{type}:$s->{name}"}++) { print "warning: seen $s->{type}:$s->{name}\n"; next; }
1009
1010                                 #print " $s->{name}\n";
1011                                 processFunc($api, $lib, $inc, $s);
1012
1013                                 #print 'func='.Dumper($s);
1014                         }
1015                 } elsif ($inc->{type} eq 'library') {
1016                         foreach my $l (grep { "$_->{type}:$_->{name}" =~ m/$inc->{regex}/ } @{$api->{api}}) {
1017                                 print " -> $l->{name}\n";
1018                                 # included libraries are never output directly
1019                                 $l->{output} = 0;
1020                                 processLibrary($api, $seen, $l, $ctx);
1021                         }
1022                 } elsif ($inc->{type} =~ m/define|enum/on) {
1023                         # suppress direct output of anything included
1024                         foreach my $c (findMatches($api, $inc, $ctx)) {
1025                                 $c->{output} = 0;
1026                         }
1027                 }
1028         }
1029 }
1030
1031 sub postprocess {
1032         my $api = shift;
1033         my $seen = {};
1034         my %data = %{$api->{data}};
1035
1036         # apply requested options to specific objects (not defaults)
1037         foreach my $obj (grep {$_->{type} =~ m/^(func|call|struct|union)$/} @{$api->{api}}) {
1038                 my @list = findMatches($api, $obj, $obj);
1039
1040                 if ($obj->{type} =~ m/func|call/) {
1041                         processTypeFunc($api, $seen, $obj, @list);
1042                 } else {
1043                         processType($api, $seen, $obj, @list);
1044                 }
1045         }
1046
1047         # handle libraries
1048         foreach my $lib (grep {$_->{type} eq 'library'} @{$api->{api}}) {
1049                 next if defined($lib->{output});
1050                 $lib->{output} = 1;
1051                 processLibrary($api, $seen, $lib, $lib);
1052         }
1053
1054         # apply options for default object types
1055         foreach my $obj (grep {$_->{name} eq '<default>'} @{$api->{api}}) {
1056                 my @list;
1057
1058                 @list = grep { !defined($seen->{"$_->{type}:$_->{name}"}) && $_->{type} eq $obj->{type} } values %data;
1059
1060                 print "apply $obj->{type}:$obj->{name} to ".($#list + 1)." objects\n" if ($#list >= 0);
1061
1062                 if ($obj->{type} =~ m/func|call/) {
1063                         processTypeFunc($api, $seen, $obj, @list);
1064                 } else {
1065                         processType($api, $seen, $obj, @list);
1066                 }
1067         }
1068 }
1069
1070 1;