← Back to branch summary

~xnox/ubuntu/saucy/drizzle/merge

« back to all changes in this revision

Viewing changes to tests/kewpie/randgen/lib/GenTest/Grammar.pm

  • Committer: Package Import Robot
  • Author(s): Clint Byrum
  • Date: 2012-06-19 10:46:49 UTC
  • mfrom: (1.2.11) (2.1.16 sid)
  • Revision ID: package-import@ubuntu.com-20120619104649-9ij634mxm4x8pp4l
Tags: 1:7.1.36-stable-1ubuntu1
https://launchpad.net/bugs/987575
* Merge from Debian unstable. (LP: #987575)
  Remaining changes:
  - Added upstart script.
* debian/drizzle.upstart: dropped logger since upstart logs job
  output now.

Show diffs side-by-side

added added

removed removed

Lines of Context:
tests/kewpie/randgen/lib/GenTest/Grammar.pm
 
1
# Copyright (C) 2008-2009 Sun Microsystems, Inc. All rights reserved.
 
2
# Use is subject to license terms.
 
3
#
 
4
# This program is free software; you can redistribute it and/or modify
 
5
# it under the terms of the GNU General Public License as published by
 
6
# the Free Software Foundation; version 2 of the License.
 
7
#
 
8
# This program is distributed in the hope that it will be useful, but
 
9
# WITHOUT ANY WARRANTY; without even the implied warranty of
 
10
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
 
11
# General Public License for more details.
 
12
#
 
13
# You should have received a copy of the GNU General Public License
 
14
# along with this program; if not, write to the Free Software
 
15
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301
 
16
# USA
 
17
 
 
18
package GenTest::Grammar;
 
19
 
 
20
require Exporter;
 
21
@ISA = qw(GenTest);
 
22
@EXPORT = qw(
 
23
        GRAMMAR_FLAG_COMPACT_RULES
 
24
        GRAMMAR_FLAG_SKIP_RECURSIVE_RULES
 
25
);
 
26
 
 
27
use strict;
 
28
 
 
29
use GenTest;
 
30
use GenTest::Constants;
 
31
use GenTest::Grammar::Rule;
 
32
use GenTest::Random;
 
33
 
 
34
use Data::Dumper;
 
35
 
 
36
use constant GRAMMAR_RULES      => 0;
 
37
use constant GRAMMAR_FILE       => 1;
 
38
use constant GRAMMAR_STRING     => 2;
 
39
use constant GRAMMAR_FLAGS      => 3;
 
40
 
 
41
use constant GRAMMAR_FLAG_COMPACT_RULES         => 1;
 
42
use constant GRAMMAR_FLAG_SKIP_RECURSIVE_RULES  => 2;
 
43
 
 
44
1;
 
45
 
 
46
sub new {
 
47
        my $class = shift;
 
48
 
 
49
 
 
50
        my $grammar = $class->SUPER::new({
 
51
                'grammar_file'                  => GRAMMAR_FILE,
 
52
                'grammar_string'                => GRAMMAR_STRING,
 
53
                'grammar_flags'         => GRAMMAR_FLAGS,
 
54
                'grammar_rules'         => GRAMMAR_RULES
 
55
        }, @_);
 
56
 
 
57
 
 
58
    if (defined $grammar->rules()) {
 
59
        $grammar->[GRAMMAR_STRING] = $grammar->toString();
 
60
    } else {
 
61
        $grammar->[GRAMMAR_RULES] = {};
 
62
        
 
63
        if (defined $grammar->file()) {
 
64
            my $parse_result = $grammar->parseFromFile($grammar->file());
 
65
            return undef if $parse_result > STATUS_OK;
 
66
        }
 
67
        
 
68
        if (defined $grammar->string()) {
 
69
            my $parse_result = $grammar->parseFromString($grammar->string());
 
70
            return undef if $parse_result > STATUS_OK;
 
71
        }
 
72
    }
 
73
 
 
74
        return $grammar;
 
75
}
 
76
 
 
77
sub file {
 
78
        return $_[0]->[GRAMMAR_FILE];
 
79
}
 
80
 
 
81
sub string {
 
82
        return $_[0]->[GRAMMAR_STRING];
 
83
}
 
84
 
 
85
 
 
86
sub toString {
 
87
        my $grammar = shift;
 
88
        my $rules = $grammar->rules();
 
89
        return join("\n\n", map { $grammar->rule($_)->toString() } sort keys %$rules);
 
90
}
 
91
 
 
92
 
 
93
sub parseFromFile {
 
94
        my ($grammar, $grammar_file) = @_;
 
95
 
 
96
        open (GF, $grammar_file) or die "Unable to open() grammar $grammar_file: $!";
 
97
        read (GF, my $grammar_string, -s $grammar_file) or die "Unable to read() $grammar_file: $!";
 
98
 
 
99
        $grammar->[GRAMMAR_STRING] = $grammar_string;
 
100
 
 
101
        return $grammar->parseFromString($grammar_string);
 
102
}
 
103
 
 
104
sub parseFromString {
 
105
        my ($grammar, $grammar_string) = @_;
 
106
 
 
107
        #
 
108
        # provide an #include directive 
 
109
        #
 
110
 
 
111
        while ($grammar_string =~ s{#include [<"](.*?)[>"]$}{
 
112
                {
 
113
                        my $include_string;
 
114
                        my $include_file = $1;
 
115
                        open (IF, $1) or die "Unable to open include file $include_file: $!";
 
116
                        read (IF, my $include_string, -s $include_file) or die "Unable to open $include_file: $!";
 
117
                        $include_string;
 
118
        }}mie) {};
 
119
 
 
120
        # Strip comments. Note that this is not Perl-code safe, since perl fragments 
 
121
        # can contain both comments with # and the $# expression. A proper lexer will fix this
 
122
        
 
123
        $grammar_string =~ s{#.*$}{}iomg;
 
124
 
 
125
        # Join lines ending in \
 
126
 
 
127
        $grammar_string =~ s{\\$}{ }iomg;
 
128
 
 
129
        # Strip end-line whitespace
 
130
 
 
131
        $grammar_string =~ s{\s+$}{}iomg;
 
132
 
 
133
        # Add terminating \n to ease parsing
 
134
 
 
135
        $grammar_string = $grammar_string."\n";
 
136
 
 
137
        my @rule_strings = split (";\s*[\r\n]+", $grammar_string);
 
138
 
 
139
        my %rules;
 
140
 
 
141
        foreach my $rule_string (@rule_strings) {
 
142
                my ($rule_name, $components_string) = $rule_string =~ m{^(.*?)\s*:(.*)$}sio;
 
143
 
 
144
                $rule_name =~ s{[\r\n]}{}gsio;
 
145
                $rule_name =~ s{^\s*}{}gsio;
 
146
 
 
147
                next if $rule_name eq '';
 
148
 
 
149
                say("Warning: Rule $rule_name is defined twice.") if exists $rules{$rule_name};
 
150
 
 
151
                my @component_strings = split (m{\|}, $components_string);
 
152
                my @components;
 
153
                my %components;
 
154
 
 
155
                foreach my $component_string (@component_strings) {
 
156
                        # Remove leading whitespace
 
157
                        $component_string =~ s{^\s+}{}sgio;
 
158
                        $component_string =~ s{\s+$}{}sgio;
 
159
                
 
160
                        # Rempove repeating whitespaces
 
161
                        $component_string =~ s{\s+}{ }sgio;
 
162
 
 
163
                        # Split this so that each identifier is separated from all syntax elements
 
164
                        # The identifier can start with a lowercase letter or an underscore , plus quotes
 
165
 
 
166
                        $component_string =~ s{([_a-z0-9'"`\{\}\$\[\]]+)}{|$1|}sgio;
 
167
 
 
168
                        # Revert overzealous splitting that splits things like _varchar(32) into several tokens
 
169
                
 
170
                        $component_string =~ s{([a-z0-9_]+)\|\(\|(\d+)\|\)}{$1($2)|}sgo;
 
171
 
 
172
                        # Remove leading and trailing pipes
 
173
                        $component_string =~ s{^\|}{}sgio;
 
174
                        $component_string =~ s{\|$}{}sgio;
 
175
 
 
176
                        if (
 
177
                                (exists $components{$component_string}) &&
 
178
                                ($grammar->[GRAMMAR_FLAGS] & GRAMMAR_FLAG_COMPACT_RULES)
 
179
                        ) {
 
180
                                next;
 
181
                        } else {
 
182
                                $components{$component_string}++;
 
183
                        }
 
184
 
 
185
                        my @component_parts = split (m{\|}, $component_string);
 
186
 
 
187
                        if (
 
188
                                (grep { $_ eq $rule_name } @component_parts) &&
 
189
                                ($grammar->[GRAMMAR_FLAGS] & GRAMMAR_FLAG_SKIP_RECURSIVE_RULES)
 
190
                        ) {
 
191
                                say("Skipping recursive production in rule '$rule_name'.") if rqg_debug();
 
192
                                next;
 
193
                        }
 
194
 
 
195
                        #
 
196
                        # If this grammar rule contains Perl code, assemble it between the various
 
197
                        # component parts it was split into. This "reconstructive" step is definitely bad design
 
198
                        # The way to do it properly would be to tokenize the grammar using a full-blown lexer
 
199
                        # which should hopefully come up in a future version.
 
200
                        #
 
201
 
 
202
                        my $nesting_level = 0;
 
203
                        my $pos = 0;
 
204
                        my $code_start;
 
205
 
 
206
                        while (1) {
 
207
                                if ($component_parts[$pos] =~ m{\{}so) {
 
208
                                        $code_start = $pos if $nesting_level == 0;      # Code segment starts here
 
209
                                        my $bracket_count = ($component_parts[$pos] =~ tr/{//);
 
210
                                        $nesting_level = $nesting_level + $bracket_count;
 
211
                                }
 
212
                                
 
213
                                if ($component_parts[$pos] =~ m{\}}so) {
 
214
                                        my $bracket_count = ($component_parts[$pos] =~ tr/}//);
 
215
                                        $nesting_level = $nesting_level - $bracket_count;
 
216
                                        if ($nesting_level == 0) {
 
217
                                                # Resemble the entire Perl code segment into a single string
 
218
                                                splice(@component_parts, $code_start, ($pos - $code_start + 1) , join ('', @component_parts[$code_start..$pos]));
 
219
                                                $pos = $code_start + 1;
 
220
                                                $code_start = undef;
 
221
                                        }
 
222
                                }
 
223
                                last if $pos > $#component_parts;
 
224
                                $pos++;
 
225
                        }
 
226
 
 
227
                        push @components, \@component_parts;
 
228
                }
 
229
 
 
230
                my $rule = GenTest::Grammar::Rule->new(
 
231
                        name => $rule_name,
 
232
                        components => \@components
 
233
                );
 
234
                $rules{$rule_name} = $rule;
 
235
        }
 
236
 
 
237
        $grammar->[GRAMMAR_RULES] = \%rules;
 
238
        return STATUS_OK;
 
239
}
 
240
 
 
241
sub rule {
 
242
        return $_[0]->[GRAMMAR_RULES]->{$_[1]};
 
243
}
 
244
 
 
245
sub rules {
 
246
        return $_[0]->[GRAMMAR_RULES];
 
247
}
 
248
 
 
249
sub deleteRule {
 
250
        delete $_[0]->[GRAMMAR_RULES]->{$_[1]};
 
251
}
 
252
 
 
253
#
 
254
# Check if the grammar is tagged with query properties such as RESULTSET_ or ERROR_1234
 
255
#
 
256
 
 
257
sub hasProperties {
 
258
        if ($_[0]->[GRAMMAR_STRING] =~ m{RESULTSET_|ERROR_|QUERY_}so) {
 
259
                return 1;
 
260
        } else {
 
261
                return 0;
 
262
        }
 
263
}
 
264
 
 
265
##
 
266
## Make a new grammar using the patch_grammar to replace old rules and
 
267
## add new rules.
 
268
##
 
269
sub patch {
 
270
    my ($self, $patch_grammar) = @_;
 
271
 
 
272
    my $patch_rules = $patch_grammar->rules();
 
273
 
 
274
    my $rules = $self->rules();
 
275
 
 
276
    foreach my $ruleName (keys %$patch_rules) {
 
277
        $rules->{$ruleName} = $patch_rules->{$ruleName};
 
278
    }
 
279
 
 
280
    my $new_grammar = GenTest::Grammar->new(grammar_rules => $rules);
 
281
    return $new_grammar;
 
282
}
 
283
 
 
284
 
 
285
sub firstMatchingRule {
 
286
    my ($self, @ids) = @_;
 
287
    foreach my $x (@ids) {
 
288
        return $self->rule($x) if defined $self->rule($x);
 
289
    }
 
290
    return undef;
 
291
}
 
292
 
 
293
##
 
294
## The "body" of topGrammar
 
295
##
 
296
 
 
297
sub topGrammarX {
 
298
    my ($self, $level, $max, @rules) = @_;
 
299
    if ($max > 0) {
 
300
        my $result={};
 
301
        foreach my $rule (@rules) {
 
302
            foreach my $c (@{$rule->components()}) {
 
303
                my @subrules = ();
 
304
                foreach my $cp (@$c) {
 
305
                    push @subrules,$self->rule($cp) if defined $self->rule($cp);
 
306
                }
 
307
                my $componentrules = 
 
308
                    $self->topGrammarX($level + 1, $max -1,@subrules);
 
309
                if (defined  $componentrules) {
 
310
                    foreach my $sr (keys %$componentrules) {
 
311
                        $result->{$sr} = $componentrules->{$sr};
 
312
                    }
 
313
                }
 
314
            }
 
315
            $result->{$rule->name()} = $rule;
 
316
        }
 
317
        return $result;
 
318
    } else {
 
319
        return undef;
 
320
    }
 
321
}
 
322
 
 
323
 
 
324
##
 
325
## Produce a new grammar which is the toplevel $level rules of this
 
326
## grammar
 
327
##
 
328
 
 
329
sub topGrammar {
 
330
    my ($self, $levels, @startrules) = @_;
 
331
 
 
332
    my $start = $self->firstMatchingRule(@startrules);
 
333
 
 
334
    my $rules = $self->topGrammarX(0,$levels, $start);
 
335
 
 
336
    return GenTest::Grammar->new(grammar_rules => $rules);
 
337
}
 
338
 
 
339
##
 
340
## Produce a new grammar keeping a masked set of rules. The mask is 16
 
341
## bits. If the mask is too short, we use the original mask as a seed
 
342
## for a random number generator and generate more 16-bit values as
 
343
## needed. The mask is applied in alphapetical order on the rules to
 
344
## ensure a deterministicresult since I don't trust the Perl %hashes
 
345
## to be always ordered the same twhen they are produced e.g. from
 
346
## topGrammar or whatever...
 
347
##
 
348
 
 
349
 
 
350
sub mask {
 
351
    my ($self, $mask) = @_;
 
352
 
 
353
 
 
354
    my $rules = $self->rules();
 
355
 
 
356
    my %newRuleset;
 
357
 
 
358
    my $i = 0;
 
359
    my $prng = GenTest::Random->new(seed => $mask);
 
360
    ## Generate the first 16 bits.
 
361
    my $mask16 = $prng->uint16(0,0x7fff);
 
362
    foreach my $rulename (sort keys %$rules) {
 
363
        my $rule = $self->rule($rulename);
 
364
        my @newComponents;
 
365
        foreach my $x (@{$rule->components()}) {
 
366
            push @newComponents, $x if (1 << ($i++)) & $mask16;
 
367
            if ($i % 16 == 0) {
 
368
                # We need more bits!
 
369
                $i = 0;
 
370
                $mask = $prng->uint16(0,0x7fff);
 
371
            }
 
372
        }
 
373
        
 
374
        my $newRule;
 
375
 
 
376
        ## If no components were chosen, we chose all to have a working
 
377
        ## grammar.
 
378
        if ($#newComponents < 0) {
 
379
            $newRule = $rule;
 
380
        } else {
 
381
            $newRule= GenTest::Grammar::Rule->new(name => $rulename,
 
382
                                              components => \@newComponents);
 
383
        }
 
384
        $newRuleset{$rulename}= $newRule;
 
385
        
 
386
    }
 
387
 
 
388
    return GenTest::Grammar->new(grammar_rules => \%newRuleset);
 
389
}
 
390
 
 
391
1;