← Back to branch summary

~zulcss/samba/server-dailies-3.4

« back to all changes in this revision

Viewing changes to pidl/lib/Parse/Yapp/Driver.pm

  • Committer: Chuck Short
  • Date: 2010-09-28 20:38:39 UTC
  • Revision ID: zulcss@ubuntu.com-20100928203839-pgjulytsi9ue63x1
Initial version

Show diffs side-by-side

added added

removed removed

Lines of Context:
pidl/lib/Parse/Yapp/Driver.pm
 
1
#
 
2
# Module Parse::Yapp::Driver
 
3
#
 
4
# This module is part of the Parse::Yapp package available on your
 
5
# nearest CPAN
 
6
#
 
7
# Any use of this module in a standalone parser make the included
 
8
# text under the same copyright as the Parse::Yapp module itself.
 
9
#
 
10
# This notice should remain unchanged.
 
11
#
 
12
# (c) Copyright 1998-2001 Francois Desarmenien, all rights reserved.
 
13
# (see the pod text in Parse::Yapp module for use and distribution rights)
 
14
#
 
15
 
 
16
package Parse::Yapp::Driver;
 
17
 
 
18
require 5.004;
 
19
 
 
20
use strict;
 
21
 
 
22
use vars qw ( $VERSION $COMPATIBLE $FILENAME );
 
23
 
 
24
$VERSION = '1.05';
 
25
$COMPATIBLE = '0.07';
 
26
$FILENAME=__FILE__;
 
27
 
 
28
use Carp;
 
29
 
 
30
#Known parameters, all starting with YY (leading YY will be discarded)
 
31
my(%params)=(YYLEX => 'CODE', 'YYERROR' => 'CODE', YYVERSION => '',
 
32
                         YYRULES => 'ARRAY', YYSTATES => 'ARRAY', YYDEBUG => '');
 
33
#Mandatory parameters
 
34
my(@params)=('LEX','RULES','STATES');
 
35
 
 
36
sub new {
 
37
    my($class)=shift;
 
38
        my($errst,$nberr,$token,$value,$check,$dotpos);
 
39
    my($self)={ ERROR => \&_Error,
 
40
                                ERRST => \$errst,
 
41
                NBERR => \$nberr,
 
42
                                TOKEN => \$token,
 
43
                                VALUE => \$value,
 
44
                                DOTPOS => \$dotpos,
 
45
                                STACK => [],
 
46
                                DEBUG => 0,
 
47
                                CHECK => \$check };
 
48
 
 
49
        _CheckParams( [], \%params, \@_, $self );
 
50
 
 
51
                exists($$self{VERSION})
 
52
        and     $$self{VERSION} < $COMPATIBLE
 
53
        and     croak "Yapp driver version $VERSION ".
 
54
                          "incompatible with version $$self{VERSION}:\n".
 
55
                          "Please recompile parser module.";
 
56
 
 
57
        ref($class)
 
58
    and $class=ref($class);
 
59
 
 
60
    bless($self,$class);
 
61
}
 
62
 
 
63
sub YYParse {
 
64
    my($self)=shift;
 
65
    my($retval);
 
66
 
 
67
        _CheckParams( \@params, \%params, \@_, $self );
 
68
 
 
69
        if($$self{DEBUG}) {
 
70
                _DBLoad();
 
71
                $retval = eval '$self->_DBParse()';#Do not create stab entry on compile
 
72
        $@ and die $@;
 
73
        }
 
74
        else {
 
75
                $retval = $self->_Parse();
 
76
        }
 
77
    $retval
 
78
}
 
79
 
 
80
sub YYData {
 
81
        my($self)=shift;
 
82
 
 
83
                exists($$self{USER})
 
84
        or      $$self{USER}={};
 
85
 
 
86
        $$self{USER};
 
87
        
 
88
}
 
89
 
 
90
sub YYErrok {
 
91
        my($self)=shift;
 
92
 
 
93
        ${$$self{ERRST}}=0;
 
94
    undef;
 
95
}
 
96
 
 
97
sub YYNberr {
 
98
        my($self)=shift;
 
99
 
 
100
        ${$$self{NBERR}};
 
101
}
 
102
 
 
103
sub YYRecovering {
 
104
        my($self)=shift;
 
105
 
 
106
        ${$$self{ERRST}} != 0;
 
107
}
 
108
 
 
109
sub YYAbort {
 
110
        my($self)=shift;
 
111
 
 
112
        ${$$self{CHECK}}='ABORT';
 
113
    undef;
 
114
}
 
115
 
 
116
sub YYAccept {
 
117
        my($self)=shift;
 
118
 
 
119
        ${$$self{CHECK}}='ACCEPT';
 
120
    undef;
 
121
}
 
122
 
 
123
sub YYError {
 
124
        my($self)=shift;
 
125
 
 
126
        ${$$self{CHECK}}='ERROR';
 
127
    undef;
 
128
}
 
129
 
 
130
sub YYSemval {
 
131
        my($self)=shift;
 
132
        my($index)= $_[0] - ${$$self{DOTPOS}} - 1;
 
133
 
 
134
                $index < 0
 
135
        and     -$index <= @{$$self{STACK}}
 
136
        and     return $$self{STACK}[$index][1];
 
137
 
 
138
        undef;  #Invalid index
 
139
}
 
140
 
 
141
sub YYCurtok {
 
142
        my($self)=shift;
 
143
 
 
144
        @_
 
145
    and ${$$self{TOKEN}}=$_[0];
 
146
    ${$$self{TOKEN}};
 
147
}
 
148
 
 
149
sub YYCurval {
 
150
        my($self)=shift;
 
151
 
 
152
        @_
 
153
    and ${$$self{VALUE}}=$_[0];
 
154
    ${$$self{VALUE}};
 
155
}
 
156
 
 
157
sub YYExpect {
 
158
    my($self)=shift;
 
159
 
 
160
    keys %{$self->{STATES}[$self->{STACK}[-1][0]]{ACTIONS}}
 
161
}
 
162
 
 
163
sub YYLexer {
 
164
    my($self)=shift;
 
165
 
 
166
        $$self{LEX};
 
167
}
 
168
 
 
169
 
 
170
#################
 
171
# Private stuff #
 
172
#################
 
173
 
 
174
 
 
175
sub _CheckParams {
 
176
        my($mandatory,$checklist,$inarray,$outhash)=@_;
 
177
        my($prm,$value);
 
178
        my($prmlst)={};
 
179
 
 
180
        while(($prm,$value)=splice(@$inarray,0,2)) {
 
181
        $prm=uc($prm);
 
182
                        exists($$checklist{$prm})
 
183
                or      croak("Unknow parameter '$prm'");
 
184
                        ref($value) eq $$checklist{$prm}
 
185
                or      croak("Invalid value for parameter '$prm'");
 
186
        $prm=unpack('@2A*',$prm);
 
187
                $$outhash{$prm}=$value;
 
188
        }
 
189
        for (@$mandatory) {
 
190
                        exists($$outhash{$_})
 
191
                or      croak("Missing mandatory parameter '".lc($_)."'");
 
192
        }
 
193
}
 
194
 
 
195
sub _Error {
 
196
        print "Parse error.\n";
 
197
}
 
198
 
 
199
sub _DBLoad {
 
200
        {
 
201
                no strict 'refs';
 
202
 
 
203
                        exists(${__PACKAGE__.'::'}{_DBParse})#Already loaded ?
 
204
                and     return;
 
205
        }
 
206
        my($fname)=__FILE__;
 
207
        my(@drv);
 
208
        open(DRV,"<$fname") or die "Report this as a BUG: Cannot open $fname";
 
209
        while(<DRV>) {
 
210
                        /^\s*sub\s+_Parse\s*{\s*$/ .. /^\s*}\s*#\s*_Parse\s*$/
 
211
                and     do {
 
212
                        s/^#DBG>//;
 
213
                        push(@drv,$_);
 
214
                }
 
215
        }
 
216
        close(DRV);
 
217
 
 
218
        $drv[0]=~s/_P/_DBP/;
 
219
        eval join('',@drv);
 
220
}
 
221
 
 
222
#Note that for loading debugging version of the driver,
 
223
#this file will be parsed from 'sub _Parse' up to '}#_Parse' inclusive.
 
224
#So, DO NOT remove comment at end of sub !!!
 
225
sub _Parse {
 
226
    my($self)=shift;
 
227
 
 
228
        my($rules,$states,$lex,$error)
 
229
     = @$self{ 'RULES', 'STATES', 'LEX', 'ERROR' };
 
230
        my($errstatus,$nberror,$token,$value,$stack,$check,$dotpos)
 
231
     = @$self{ 'ERRST', 'NBERR', 'TOKEN', 'VALUE', 'STACK', 'CHECK', 'DOTPOS' };
 
232
 
 
233
#DBG>   my($debug)=$$self{DEBUG};
 
234
#DBG>   my($dbgerror)=0;
 
235
 
 
236
#DBG>   my($ShowCurToken) = sub {
 
237
#DBG>           my($tok)='>';
 
238
#DBG>           for (split('',$$token)) {
 
239
#DBG>                   $tok.=          (ord($_) < 32 or ord($_) > 126)
 
240
#DBG>                                   ?       sprintf('<%02X>',ord($_))
 
241
#DBG>                                   :       $_;
 
242
#DBG>           }
 
243
#DBG>           $tok.='<';
 
244
#DBG>   };
 
245
 
 
246
        $$errstatus=0;
 
247
        $$nberror=0;
 
248
        ($$token,$$value)=(undef,undef);
 
249
        @$stack=( [ 0, undef ] );
 
250
        $$check='';
 
251
 
 
252
    while(1) {
 
253
        my($actions,$act,$stateno);
 
254
 
 
255
        $stateno=$$stack[-1][0];
 
256
        $actions=$$states[$stateno];
 
257
 
 
258
#DBG>   print STDERR ('-' x 40),"\n";
 
259
#DBG>           $debug & 0x2
 
260
#DBG>   and     print STDERR "In state $stateno:\n";
 
261
#DBG>           $debug & 0x08
 
262
#DBG>   and     print STDERR "Stack:[".
 
263
#DBG>                                    join(',',map { $$_[0] } @$stack).
 
264
#DBG>                                    "]\n";
 
265
 
 
266
 
 
267
        if  (exists($$actions{ACTIONS})) {
 
268
 
 
269
                                defined($$token)
 
270
            or  do {
 
271
                                ($$token,$$value)=&$lex($self);
 
272
#DBG>                           $debug & 0x01
 
273
#DBG>                   and     print STDERR "Need token. Got ".&$ShowCurToken."\n";
 
274
                        };
 
275
 
 
276
            $act=   exists($$actions{ACTIONS}{$$token})
 
277
                    ?   $$actions{ACTIONS}{$$token}
 
278
                    :   exists($$actions{DEFAULT})
 
279
                        ?   $$actions{DEFAULT}
 
280
                        :   undef;
 
281
        }
 
282
        else {
 
283
            $act=$$actions{DEFAULT};
 
284
#DBG>                   $debug & 0x01
 
285
#DBG>           and     print STDERR "Don't need token.\n";
 
286
        }
 
287
 
 
288
            defined($act)
 
289
        and do {
 
290
 
 
291
                $act > 0
 
292
            and do {        #shift
 
293
 
 
294
#DBG>                           $debug & 0x04
 
295
#DBG>                   and     print STDERR "Shift and go to state $act.\n";
 
296
 
 
297
                                        $$errstatus
 
298
                                and     do {
 
299
                                        --$$errstatus;
 
300
 
 
301
#DBG>                                   $debug & 0x10
 
302
#DBG>                           and     $dbgerror
 
303
#DBG>                           and     $$errstatus == 0
 
304
#DBG>                           and     do {
 
305
#DBG>                                   print STDERR "**End of Error recovery.\n";
 
306
#DBG>                                   $dbgerror=0;
 
307
#DBG>                           };
 
308
                                };
 
309
 
 
310
 
 
311
                push(@$stack,[ $act, $$value ]);
 
312
 
 
313
                                        $$token ne ''   #Don't eat the eof
 
314
                                and     $$token=$$value=undef;
 
315
                next;
 
316
            };
 
317
 
 
318
            #reduce
 
319
            my($lhs,$len,$code,@sempar,$semval);
 
320
            ($lhs,$len,$code)=@{$$rules[-$act]};
 
321
 
 
322
#DBG>                   $debug & 0x04
 
323
#DBG>           and     $act
 
324
#DBG>           and     print STDERR "Reduce using rule ".-$act." ($lhs,$len): ";
 
325
 
 
326
                $act
 
327
            or  $self->YYAccept();
 
328
 
 
329
            $$dotpos=$len;
 
330
 
 
331
                unpack('A1',$lhs) eq '@'    #In line rule
 
332
            and do {
 
333
                    $lhs =~ /^\@[0-9]+\-([0-9]+)$/
 
334
                or  die "In line rule name '$lhs' ill formed: ".
 
335
                        "report it as a BUG.\n";
 
336
                $$dotpos = $1;
 
337
            };
 
338
 
 
339
            @sempar =       $$dotpos
 
340
                        ?   map { $$_[1] } @$stack[ -$$dotpos .. -1 ]
 
341
                        :   ();
 
342
 
 
343
            $semval = $code ? &$code( $self, @sempar )
 
344
                            : @sempar ? $sempar[0] : undef;
 
345
 
 
346
            splice(@$stack,-$len,$len);
 
347
 
 
348
                $$check eq 'ACCEPT'
 
349
            and do {
 
350
 
 
351
#DBG>                   $debug & 0x04
 
352
#DBG>           and     print STDERR "Accept.\n";
 
353
 
 
354
                                return($semval);
 
355
                        };
 
356
 
 
357
                $$check eq 'ABORT'
 
358
            and do {
 
359
 
 
360
#DBG>                   $debug & 0x04
 
361
#DBG>           and     print STDERR "Abort.\n";
 
362
 
 
363
                                return(undef);
 
364
 
 
365
                        };
 
366
 
 
367
#DBG>                   $debug & 0x04
 
368
#DBG>           and     print STDERR "Back to state $$stack[-1][0], then ";
 
369
 
 
370
                $$check eq 'ERROR'
 
371
            or  do {
 
372
#DBG>                           $debug & 0x04
 
373
#DBG>                   and     print STDERR 
 
374
#DBG>                               "go to state $$states[$$stack[-1][0]]{GOTOS}{$lhs}.\n";
 
375
 
 
376
#DBG>                           $debug & 0x10
 
377
#DBG>                   and     $dbgerror
 
378
#DBG>                   and     $$errstatus == 0
 
379
#DBG>                   and     do {
 
380
#DBG>                           print STDERR "**End of Error recovery.\n";
 
381
#DBG>                           $dbgerror=0;
 
382
#DBG>                   };
 
383
 
 
384
                            push(@$stack,
 
385
                     [ $$states[$$stack[-1][0]]{GOTOS}{$lhs}, $semval ]);
 
386
                $$check='';
 
387
                next;
 
388
            };
 
389
 
 
390
#DBG>                   $debug & 0x04
 
391
#DBG>           and     print STDERR "Forced Error recovery.\n";
 
392
 
 
393
            $$check='';
 
394
 
 
395
        };
 
396
 
 
397
        #Error
 
398
            $$errstatus
 
399
        or   do {
 
400
 
 
401
            $$errstatus = 1;
 
402
            &$error($self);
 
403
                $$errstatus # if 0, then YYErrok has been called
 
404
            or  next;       # so continue parsing
 
405
 
 
406
#DBG>                   $debug & 0x10
 
407
#DBG>           and     do {
 
408
#DBG>                   print STDERR "**Entering Error recovery.\n";
 
409
#DBG>                   ++$dbgerror;
 
410
#DBG>           };
 
411
 
 
412
            ++$$nberror;
 
413
 
 
414
        };
 
415
 
 
416
                        $$errstatus == 3        #The next token is not valid: discard it
 
417
                and     do {
 
418
                                $$token eq ''   # End of input: no hope
 
419
                        and     do {
 
420
#DBG>                           $debug & 0x10
 
421
#DBG>                   and     print STDERR "**At eof: aborting.\n";
 
422
                                return(undef);
 
423
                        };
 
424
 
 
425
#DBG>                   $debug & 0x10
 
426
#DBG>           and     print STDERR "**Dicard invalid token ".&$ShowCurToken.".\n";
 
427
 
 
428
                        $$token=$$value=undef;
 
429
                };
 
430
 
 
431
        $$errstatus=3;
 
432
 
 
433
                while(    @$stack
 
434
                          and (         not exists($$states[$$stack[-1][0]]{ACTIONS})
 
435
                                or  not exists($$states[$$stack[-1][0]]{ACTIONS}{error})
 
436
                                        or      $$states[$$stack[-1][0]]{ACTIONS}{error} <= 0)) {
 
437
 
 
438
#DBG>                   $debug & 0x10
 
439
#DBG>           and     print STDERR "**Pop state $$stack[-1][0].\n";
 
440
 
 
441
                        pop(@$stack);
 
442
                }
 
443
 
 
444
                        @$stack
 
445
                or      do {
 
446
 
 
447
#DBG>                   $debug & 0x10
 
448
#DBG>           and     print STDERR "**No state left on stack: aborting.\n";
 
449
 
 
450
                        return(undef);
 
451
                };
 
452
 
 
453
                #shift the error token
 
454
 
 
455
#DBG>                   $debug & 0x10
 
456
#DBG>           and     print STDERR "**Shift \$error token and go to state ".
 
457
#DBG>                                            $$states[$$stack[-1][0]]{ACTIONS}{error}.
 
458
#DBG>                                            ".\n";
 
459
 
 
460
                push(@$stack, [ $$states[$$stack[-1][0]]{ACTIONS}{error}, undef ]);
 
461
 
 
462
    }
 
463
 
 
464
    #never reached
 
465
        croak("Error in driver logic. Please, report it as a BUG");
 
466
 
 
467
}#_Parse
 
468
#DO NOT remove comment
 
469
 
 
470
1;
 
471