← Back to branch summary

~ubuntu-branches/ubuntu/trusty/mysql-5.6/trusty

« back to all changes in this revision

Viewing changes to scripts/dheadgen.pl

  • Committer: Package Import Robot
  • Author(s): James Page
  • Date: 2014-02-12 11:54:27 UTC
  • Revision ID: package-import@ubuntu.com-20140212115427-oq6tfsqxl1wuwehi
Tags: upstream-5.6.15
Import upstream version 5.6.15

Show diffs side-by-side

added added

removed removed

Lines of Context:
scripts/dheadgen.pl
 
1
#!/usr/bin/perl -w
 
2
 
 
3
#
 
4
# Copyright (c) 2008, 2009 Sun Microsystems, Inc.
 
5
# Use is subject to license terms.
 
6
#
 
7
 
 
8
#
 
9
# Redistribution and use in source and binary forms, with or without
 
10
# modification, are permitted provided that the following conditions are met:
 
11
# 
 
12
#    * Redistributions of source code must retain the above copyright
 
13
#      notice, this list of conditions and the following disclaimer. 
 
14
#    * Redistributions in binary form must reproduce the above copyright
 
15
#      notice, this list of conditions and the following disclaimer in  
 
16
#      the documentation and/or other materials provided with the       
 
17
#      distribution.
 
18
#    * Neither the name of the above-listed copyright holders nor the names
 
19
#      of its contributors may be used to endorse or promote products derived
 
20
#      from this software without specific prior written permission.  
 
21
#       
 
22
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
 
23
# IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED  
 
24
# TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
 
25
# PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
 
26
# OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
 
27
# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,     
 
28
# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR      
 
29
# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF  
 
30
# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING    
 
31
# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS      
 
32
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
33
#
 
34
# ident "@(#)dheadgen.pl        1.4     07/06/24 SMI"
 
35
 
 
36
#
 
37
# DTrace Header Generator
 
38
# -----------------------
 
39
#
 
40
# This script is meant to mimic the output of dtrace(1M) with the -h
 
41
# (headergen) flag on system that lack native support for DTrace. This script
 
42
# is intended to be integrated into projects that use DTrace's static tracing
 
43
# facilities (USDT), and invoked as part of the build process to have a
 
44
# common build process on all target systems. To facilitate this, this script
 
45
# is licensed under a BSD license. On system with native DTrace support, the
 
46
# dtrace(1M) command will be invoked to create the full header file; on other
 
47
# systems, this script will generated a stub header file.
 
48
#
 
49
# Normally, generated macros take the form PROVIDER_PROBENAME().  It may be
 
50
# desirable to customize the output of this script and of dtrace(1M) to
 
51
# tailor the precise macro name. To do this, edit the emit_dtrace() subroutine
 
52
# to pattern match for the lines you want to customize.
 
53
#
 
54
 
 
55
use strict;
 
56
 
 
57
my @lines;
 
58
my @tokens = ();
 
59
my $lineno = 0;
 
60
my $newline = 1;
 
61
my $eof = 0;
 
62
my $infile;
 
63
my $outfile;
 
64
my $force = 0;
 
65
 
 
66
sub emit_dtrace {
 
67
        my ($line) = @_;
 
68
 
 
69
        #
 
70
        # Insert customization here. For example, if you want to change the
 
71
        # name of the macros you may do something like this:
 
72
        #
 
73
        # $line =~ s/(\s)[A-Z]+_/\1TRACE_MOZILLA_/;
 
74
        #
 
75
 
 
76
        print $line;
 
77
}
 
78
 
 
79
#
 
80
# The remaining code deals with parsing D provider definitions and emitting
 
81
# the stub header file. There should be no need to edit this absent a bug.
 
82
#
 
83
 
 
84
#
 
85
# Emit the two relevant macros for each probe in the given provider:
 
86
#    PROVIDER_PROBENAME(<args>)
 
87
#    PROVIDER_PROBENAME_ENABLED() (0)
 
88
#
 
89
sub emit_provider {
 
90
        my ($provname, @probes) = @_;
 
91
 
 
92
        $provname = uc($provname);
 
93
 
 
94
        foreach my $probe (@probes) {
 
95
                my $probename = uc($$probe{'name'});
 
96
                my $argc = $$probe{'argc'};
 
97
                my $line;
 
98
 
 
99
                $probename =~ s/__/_/g;
 
100
 
 
101
                $line = "#define\t${provname}_${probename}(";
 
102
                for (my $i = 0; $i < $argc; $i++) {
 
103
                        $line .= ($i == 0 ? '' : ', ');
 
104
                        $line .= "arg$i";
 
105
                }
 
106
                $line .= ")\n";
 
107
                emit_dtrace($line);
 
108
                
 
109
                $line = "#define\t${provname}_${probename}_ENABLED() (0)\n";
 
110
                emit_dtrace($line);
 
111
        }
 
112
 
 
113
        emit_dtrace("\n");
 
114
}
 
115
 
 
116
sub emit_prologue {
 
117
        my ($filename) = @_;
 
118
 
 
119
        $filename =~ s/.*\///g;
 
120
        $filename = uc($filename);
 
121
        $filename =~ s/\./_/g;
 
122
 
 
123
        emit_dtrace <<"EOF";
 
124
/*
 
125
 * Generated by dheadgen(1).
 
126
 */
 
127
 
 
128
#ifndef\t_${filename}
 
129
#define\t_${filename}
 
130
 
 
131
#ifdef\t__cplusplus
 
132
extern "C" {
 
133
#endif
 
134
 
 
135
EOF
 
136
}
 
137
 
 
138
sub emit_epilogue {
 
139
        my ($filename) = @_;
 
140
 
 
141
        $filename =~ s/.*\///g;
 
142
        $filename = uc($filename);
 
143
        $filename =~ s/\./_/g;
 
144
 
 
145
        emit_dtrace <<"EOF";
 
146
#ifdef  __cplusplus
 
147
}
 
148
#endif
 
149
 
 
150
#endif  /* _$filename */
 
151
EOF
 
152
}
 
153
 
 
154
#
 
155
# Get the next token from the file keeping track of the line number.
 
156
#
 
157
sub get_token {
 
158
        my ($eof_ok) = @_;
 
159
        my $tok;
 
160
 
 
161
        while (1) {
 
162
                while (scalar(@tokens) == 0) {
 
163
                        if (scalar(@lines) == 0) {
 
164
                                $eof = 1;
 
165
                                return if ($eof_ok);
 
166
                                die "expected more data at line $lineno";
 
167
                        }
 
168
 
 
169
                        $lineno++;
 
170
                        push(@tokens, split(/(\s+|\n|[(){},#;]|\/\*|\*\/)/,
 
171
                            shift(@lines)));
 
172
                }
 
173
 
 
174
                $tok = shift(@tokens);
 
175
                next if ($tok eq '');
 
176
                next if ($tok =~ /^[ \t]+$/);
 
177
 
 
178
                return ($tok);
 
179
        }
 
180
}
 
181
 
 
182
#
 
183
# Ignore newlines, comments and typedefs
 
184
#
 
185
sub next_token {
 
186
        my ($eof_ok) = @_;
 
187
        my $tok;
 
188
 
 
189
        while (1) {
 
190
                $tok = get_token($eof_ok);
 
191
                return if ($eof_ok && $eof);
 
192
                if ($tok eq "typedef" or $tok =~ /^#/) {
 
193
                  while (1) {
 
194
                    $tok = get_token(0);
 
195
                    last if ($tok eq "\n");
 
196
                  }
 
197
                  next;
 
198
                } elsif ($tok eq '/*') {
 
199
                        while (get_token(0) ne '*/') {
 
200
                                next;
 
201
                        }
 
202
                        next;
 
203
                } elsif ($tok eq "\n") {
 
204
                        next;
 
205
                }
 
206
 
 
207
                last;
 
208
        }
 
209
 
 
210
        return ($tok);
 
211
}
 
212
 
 
213
sub expect_token {
 
214
        my ($t) = @_;
 
215
        my $tok;
 
216
 
 
217
        while (($tok = next_token(0)) eq "\n") {
 
218
                next;
 
219
        }
 
220
 
 
221
        die "expected '$t' at line $lineno rather than '$tok'" if ($t ne $tok);
 
222
}
 
223
 
 
224
sub get_args {
 
225
        expect_token('(');
 
226
 
 
227
        my $tok = next_token(0);
 
228
        my @args = ();
 
229
 
 
230
        return (@args) if ($tok eq ')');
 
231
 
 
232
        if ($tok eq 'void') {
 
233
                expect_token(')');
 
234
                return (@args);
 
235
        }
 
236
 
 
237
        my $arg = $tok;
 
238
 
 
239
        while (1) {
 
240
                $tok = next_token(0);
 
241
                if ($tok eq ',' || $tok eq ')') {
 
242
                        push(@args, $arg);
 
243
                        $arg = '';
 
244
                        last if ($tok eq ')');
 
245
                } else {
 
246
                        $arg = "$arg $tok";
 
247
                }
 
248
        }
 
249
 
 
250
        return (@args);
 
251
}
 
252
 
 
253
sub usage {
 
254
        die "usage: $0 [-f] <filename.d>\n";
 
255
}
 
256
 
 
257
usage() if (scalar(@ARGV) < 1);
 
258
if ($ARGV[0] eq '-f') {
 
259
        usage() if (scalar(@ARGV < 2));
 
260
        $force = 1;
 
261
        shift;
 
262
}
 
263
$infile = $ARGV[0];
 
264
usage() if ($infile !~ /(.+)\.d$/);
 
265
 
 
266
#
 
267
# If the system has native support for DTrace, we'll use that binary instead.
 
268
#
 
269
if (-x '/usr/sbin/dtrace' && !$force) {
 
270
        open(DTRACE, "-| /usr/sbin/dtrace -C -h -s $infile -o /dev/stdout")
 
271
            or die "can't invoke dtrace(1M)";
 
272
 
 
273
        while (<DTRACE>) {
 
274
                emit_dtrace($_);
 
275
        }
 
276
 
 
277
        close(DTRACE);
 
278
 
 
279
        exit(0);
 
280
}
 
281
 
 
282
emit_prologue($infile);
 
283
 
 
284
open(D, "< $infile") or die "couldn't open $infile";
 
285
@lines = <D>;
 
286
close(D);
 
287
 
 
288
while (1) {
 
289
        my $nl = 0;
 
290
        my $tok = next_token(1);
 
291
        last if $eof;
 
292
 
 
293
        if ($newline && $tok eq '#') {
 
294
                while (1) {
 
295
                        $tok = get_token(0);
 
296
 
 
297
                        last if ($tok eq "\n");
 
298
                }
 
299
                $nl = 1;
 
300
        } elsif ($tok eq "\n") {
 
301
                $nl = 1;
 
302
        } elsif ($tok eq 'provider') {
 
303
                my $provname = next_token(0);
 
304
                my @probes = ();
 
305
                expect_token('{');
 
306
 
 
307
                while (1) {
 
308
                        $tok = next_token(0);
 
309
                        if ($tok eq 'probe') {
 
310
                                my $probename = next_token(0);
 
311
                                my @args = get_args();
 
312
 
 
313
                                next while (next_token(0) ne ';');
 
314
 
 
315
                                push(@probes, {
 
316
                                    'name' => $probename,
 
317
                                    'argc' => scalar(@args)
 
318
                                });
 
319
 
 
320
                        } elsif ($tok eq '}') {
 
321
                                expect_token(';');
 
322
 
 
323
                                emit_provider($provname, @probes);
 
324
 
 
325
                                last;
 
326
                        }
 
327
                }
 
328
 
 
329
        } else {
 
330
                die "syntax error at line $lineno near '$tok'\n";
 
331
        }
 
332
 
 
333
        $newline = $nl;
 
334
}
 
335
 
 
336
emit_epilogue($infile);
 
337
 
 
338
exit(0);