pidl: handle hyper attribute for wireshark
[kai/samba-autobuild/.git] / pidl / lib / Parse / Pidl / Util.pm
1 ###################################################
2 # utility functions to support pidl
3 # Copyright tridge@samba.org 2000
4 # released under the GNU GPL
5 package Parse::Pidl::Util;
6
7 require Exporter;
8 @ISA = qw(Exporter);
9 @EXPORT = qw(has_property property_matches ParseExpr ParseExprExt is_constant make_str unmake_str print_uuid MyDumper);
10 use vars qw($VERSION);
11 $VERSION = '0.01';
12
13 use strict;
14
15 use Parse::Pidl::Expr;
16 use Parse::Pidl qw(error);
17
18 =head1 NAME
19
20 Parse::Pidl::Util - Generic utility functions for pidl
21
22 =head1 SYNOPSIS
23
24 use Parse::Pidl::Util;
25
26 =head1 DESCRIPTION
27
28 Simple module that contains a couple of trivial helper functions 
29 used throughout the various pidl modules.
30
31 =head1 FUNCTIONS
32
33 =over 4
34
35 =cut
36
37 =item B<MyDumper>
38 a dumper wrapper to prevent dependence on the Data::Dumper module
39 unless we actually need it
40
41 =cut
42
43 sub MyDumper($)
44 {
45         require Data::Dumper;
46         my $s = shift;
47         return Data::Dumper::Dumper($s);
48 }
49
50 =item B<has_property>
51 see if a pidl property list contains a given property
52
53 =cut
54 sub has_property($$)
55 {
56         my($e, $p) = @_;
57
58         return undef if (not defined($e->{PROPERTIES}));
59
60         return $e->{PROPERTIES}->{$p};
61 }
62
63 =item B<property_matches>
64 see if a pidl property matches a value
65
66 =cut
67 sub property_matches($$$)
68 {
69         my($e,$p,$v) = @_;
70
71         if (!defined has_property($e, $p)) {
72                 return undef;
73         }
74
75         if ($e->{PROPERTIES}->{$p} =~ /$v/) {
76                 return 1;
77         }
78
79         return undef;
80 }
81
82 =item B<is_constant>
83 return 1 if the string is a C constant
84
85 =cut
86 sub is_constant($)
87 {
88         my $s = shift;
89         return 1 if ($s =~ /^\d+$/);
90         return 1 if ($s =~ /^0x[0-9A-Fa-f]+$/);
91         return 0;
92 }
93
94 =item B<make_str>
95 return a "" quoted string, unless already quoted
96
97 =cut
98 sub make_str($)
99 {
100         my $str = shift;
101         if (substr($str, 0, 1) eq "\"") {
102                 return $str;
103         }
104         return "\"$str\"";
105 }
106
107 =item B<unmake_str>
108 unquote a "" quoted string
109
110 =cut
111 sub unmake_str($)
112 {
113         my $str = shift;
114         
115         $str =~ s/^\"(.*)\"$/$1/;
116
117         return $str;
118 }
119
120 =item B<print_uuid>
121 Print C representation of a UUID.
122
123 =cut
124 sub print_uuid($)
125 {
126         my ($uuid) = @_;
127         $uuid =~ s/"//g;
128         my ($time_low,$time_mid,$time_hi,$clock_seq,$node) = split /-/, $uuid;
129         return undef if not defined($node);
130
131         my @clock_seq = $clock_seq =~ /(..)/g;
132         my @node = $node =~ /(..)/g;
133
134         return "{0x$time_low,0x$time_mid,0x$time_hi," .
135                 "{".join(',', map {"0x$_"} @clock_seq)."}," .
136                 "{".join(',', map {"0x$_"} @node)."}}";
137 }
138
139 =item B<ParseExpr>
140 Interpret an IDL expression, substituting particular variables.
141
142 =cut
143 sub ParseExpr($$$)
144 {
145         my($expr, $varlist, $e) = @_;
146
147         my $x = new Parse::Pidl::Expr();
148         
149         return $x->Run($expr, sub { my $x = shift; error($e, $x); },
150                 # Lookup fn 
151                 sub { my $x = shift; 
152                           return($varlist->{$x}) if (defined($varlist->{$x})); 
153                           return $x;
154                   },
155                 undef, undef);
156 }
157
158 =item B<ParseExprExt>
159 Interpret an IDL expression, substituting particular variables. Can call 
160 callbacks when pointers are being dereferenced or variables are being used.
161
162 =cut
163 sub ParseExprExt($$$$$)
164 {
165         my($expr, $varlist, $e, $deref, $use) = @_;
166
167         my $x = new Parse::Pidl::Expr();
168         
169         return $x->Run($expr, sub { my $x = shift; error($e, $x); },
170                 # Lookup fn 
171                 sub { my $x = shift; 
172                           return($varlist->{$x}) if (defined($varlist->{$x})); 
173                           return $x;
174                   },
175                 $deref, $use);
176 }
177
178 =back
179
180 =cut
181
182 1;