← Back to branch summary

~ubuntu-branches/ubuntu/trusty/lxr-cvs/trusty

« back to all changes in this revision

Viewing changes to lib/LXR/SimpleParse.pm

  • Committer: Bazaar Package Importer
  • Author(s): Giacomo Catenazzi
  • Date: 2004-01-27 20:34:44 UTC
  • Revision ID: james.westby@ubuntu.com-20040127203444-kb8xobdp8j1z8owi
Tags: upstream-0.9.2
Import upstream version 0.9.2

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/LXR/SimpleParse.pm
 
1
# -*- tab-width: 4 -*- ###############################################
 
2
#
 
3
# $Id: SimpleParse.pm,v 1.14 2001/11/14 15:03:29 mbox Exp $
 
4
 
 
5
# This program is free software; you can redistribute it and/or modify
 
6
# it under the terms of the GNU General Public License as published by
 
7
# the Free Software Foundation; either version 2 of the License, or
 
8
# (at your option) any later version.
 
9
#
 
10
# This program is distributed in the hope that it will be useful,
 
11
# but WITHOUT ANY WARRANTY; without even the implied warranty of
 
12
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
13
# GNU General Public License for more details.
 
14
# 
 
15
# You should have received a copy of the GNU General Public License
 
16
# along with this program; if not, write to the Free Software
 
17
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
18
 
 
19
package LXR::SimpleParse;
 
20
 
 
21
$CVSID = '$Id: SimpleParse.pm,v 1.14 2001/11/14 15:03:29 mbox Exp $ ';
 
22
 
 
23
use strict;
 
24
use integer;
 
25
 
 
26
require Exporter;
 
27
 
 
28
use vars qw(@ISA @EXPORT);
 
29
 
 
30
@ISA = qw(Exporter);
 
31
@EXPORT = qw(&doparse &untabify &init &nextfrag);
 
32
 
 
33
my $fileh;                      # File handle
 
34
my @frags;                      # Fragments in queue
 
35
my @bodyid;                     # Array of body type ids
 
36
my @open;                       # Fragment opening delimiters
 
37
my @term;                       # Fragment closing delimiters
 
38
my $split;                      # Fragmentation regexp
 
39
my $open;                       # Fragment opening regexp
 
40
my $tabwidth;           # Tab width
 
41
 
 
42
sub init {
 
43
    my @blksep;
 
44
        
 
45
        $fileh = "";
 
46
        @frags = ();
 
47
        @bodyid = ();
 
48
        @open = ();
 
49
        @term = ();
 
50
        $split = "";
 
51
        $open = "";
 
52
        $tabwidth = 8;
 
53
        my $tabhint;
 
54
 
 
55
    ($fileh, $tabhint, @blksep) = @_;
 
56
        $tabwidth = $tabhint || $tabwidth;
 
57
                
 
58
    while (@_ = splice(@blksep,0,3)) {
 
59
                push(@bodyid, $_[0]);
 
60
                push(@open, $_[1]);
 
61
                push(@term, $_[2]);
 
62
    }
 
63
 
 
64
    foreach (@open) {
 
65
                $open .= "($_)|";
 
66
                $split .= "$_|";
 
67
    }
 
68
    chop($open);
 
69
    
 
70
    foreach (@term) {
 
71
                next if $_ eq '';
 
72
                $split .= "$_|";
 
73
    }
 
74
    chop($split);
 
75
}
 
76
 
 
77
 
 
78
sub untabify {
 
79
    my $t = $_[1] || 8;
 
80
 
 
81
    $_[0] =~ s/^(\t+)/(' ' x ($t * length($1)))/ge; # Optimize for common case.
 
82
    $_[0] =~ s/([^\t]*)\t/$1.(' ' x ($t - (length($1) % $t)))/ge;
 
83
    return($_[0]);
 
84
}
 
85
 
 
86
 
 
87
sub nextfrag {
 
88
    my $btype = undef;
 
89
    my $frag = undef;
 
90
        my $line = '';
 
91
 
 
92
#       print "nextfrag called\n";
 
93
 
 
94
    while (1) {
 
95
 
 
96
                # read one more line if we have processed 
 
97
                # all of the previously read line
 
98
                if ($#frags < 0) {
 
99
                        $line = $fileh->getline;
 
100
                        
 
101
                        if ($. <= 2 &&
 
102
                                $line =~ /^.*-[*]-.*?[ \t;]tab-width:[ \t]*([0-9]+).*-[*]-/) {
 
103
                                $tabwidth = $1;
 
104
                        }
 
105
                        
 
106
#                       &untabify($line, $tabwidth); # We inline this for performance.
 
107
                        
 
108
                        # Optimize for common case.
 
109
                        if(defined($line)) {
 
110
                                $line =~ s/^(\t+)/' ' x ($tabwidth * length($1))/ge;
 
111
                                $line =~ s/([^\t]*)\t/$1.(' ' x ($tabwidth - (length($1) % $tabwidth)))/ge;
 
112
                                
 
113
                                # split the line into fragments
 
114
                                @frags = split(/($split)/, $line);
 
115
                        }
 
116
                }
 
117
 
 
118
                last if $#frags < 0;
 
119
                
 
120
                # skip empty fragments
 
121
                if ($frags[0] eq '') {
 
122
                        shift(@frags);
 
123
                }
 
124
 
 
125
                # check if we are inside a fragment
 
126
                if (defined($frag)) {
 
127
                        if (defined($btype)) {
 
128
                                my $next = shift(@frags);
 
129
                                
 
130
                                # Add to the fragment
 
131
                                $frag .= $next;
 
132
                                # We are done if this was the terminator
 
133
                                last if $next =~ /^$term[$btype]$/;
 
134
 
 
135
                        }
 
136
                        else {
 
137
                                if ($frags[0] =~ /^$open$/) {
 
138
#                                       print "encountered open token while btype was $btype\n";
 
139
                                        last;
 
140
                                }
 
141
                                $frag .= shift(@frags);
 
142
                        }
 
143
                }
 
144
                else {
 
145
#                       print "start of new fragment\n";
 
146
                        # Find the blocktype of the current block
 
147
                        $frag = shift(@frags);
 
148
                        if (defined($frag) && (@_ = $frag =~ /^$open$/)) {
 
149
#                               print "hit\n";
 
150
                                # grep in a scalar context returns the number of times
 
151
                                # EXPR evaluates to true, which is this case will be
 
152
                                # the index of the first defined element in @_.
 
153
 
 
154
                                my $i = 1;
 
155
                                $btype = grep { $i &&= !defined($_) } @_;
 
156
                                if(!defined($term[$btype])) {
 
157
                                        print "fragment without terminator\n";
 
158
                                        last;
 
159
                                }
 
160
                        }
 
161
                }
 
162
    }
 
163
    $btype = $bodyid[$btype] if defined($btype);
 
164
    
 
165
    return($btype, $frag);
 
166
}
 
167
 
 
168
 
 
169
1;