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 genpad parse_int parse_range);
  10 use vars qw($VERSION);
  11 $VERSION = '0.01';
  12
  13 use strict;
  14 use warnings;
  15
  16 use Parse::Pidl::Expr;
  17 use Parse::Pidl qw(error);
  18
  19 =head1 NAME
  20
  21 Parse::Pidl::Util - Generic utility functions for pidl
  22
  23 =head1 SYNOPSIS
  24
  25 use Parse::Pidl::Util;
  26
  27 =head1 DESCRIPTION
  28
  29 Simple module that contains a couple of trivial helper functions
  30 used throughout the various pidl modules.
  31
  32 =head1 FUNCTIONS
  33
  34 =over 4
  35
  36 =cut
  37
  38 =item B<MyDumper>
  39 a dumper wrapper to prevent dependence on the Data::Dumper module
  40 unless we actually need it
  41
  42 =cut
  43
  44 sub MyDumper($)
  45 {
  46         require Data::Dumper;
  47         $Data::Dumper::Sortkeys = 1;
  48         my $s = shift;
  49         return Data::Dumper::Dumper($s);
  50 }
  51
  52 =item B<has_property>
  53 see if a pidl property list contains a given property
  54
  55 =cut
  56 sub has_property($$)
  57 {
  58         my($e, $p) = @_;
  59
  60         return undef if (not defined($e->{PROPERTIES}));
  61
  62         return $e->{PROPERTIES}->{$p};
  63 }
  64
  65 =item B<property_matches>
  66 see if a pidl property matches a value
  67
  68 =cut
  69 sub property_matches($$$)
  70 {
  71         my($e,$p,$v) = @_;
  72
  73         if (!defined has_property($e, $p)) {
  74                 return undef;
  75         }
  76
  77         if ($e->{PROPERTIES}->{$p} =~ /$v/) {
  78                 return 1;
  79         }
  80
  81         return undef;
  82 }
  83
  84 =item B<is_constant>
  85 return 1 if the string is a C constant
  86
  87 =cut
  88 sub is_constant($)
  89 {
  90         my $s = shift;
  91         return 1 if ($s =~ /^\d+$/);
  92         return 1 if ($s =~ /^0x[0-9A-Fa-f]+$/);
  93         return 0;
  94 }
  95
  96 =item B<make_str>
  97 return a "" quoted string, unless already quoted
  98
  99 =cut
 100 sub make_str($)
 101 {
 102         my $str = shift;
 103         if (substr($str, 0, 1) eq "\"") {
 104                 return $str;
 105         }
 106         return "\"$str\"";
 107 }
 108
 109 =item B<unmake_str>
 110 unquote a "" quoted string
 111
 112 =cut
 113 sub unmake_str($)
 114 {
 115         my $str = shift;
 116
 117         $str =~ s/^\"(.*)\"$/$1/;
 118
 119         return $str;
 120 }
 121
 122 =item B<print_uuid>
 123 Print C representation of a UUID.
 124
 125 =cut
 126 sub print_uuid($)
 127 {
 128         my ($uuid) = @_;
 129         $uuid =~ s/"//g;
 130         my ($time_low,$time_mid,$time_hi,$clock_seq,$node) = split /-/, $uuid;
 131         return undef if not defined($node);
 132
 133         my @clock_seq = $clock_seq =~ /(..)/g;
 134         my @node = $node =~ /(..)/g;
 135
 136         return "{0x$time_low,0x$time_mid,0x$time_hi," .
 137                 "{".join(',', map {"0x$_"} @clock_seq)."}," .
 138                 "{".join(',', map {"0x$_"} @node)."}}";
 139 }
 140
 141 =item B<ParseExpr>
 142 Interpret an IDL expression, substituting particular variables.
 143
 144 =cut
 145 sub ParseExpr($$$)
 146 {
 147         my($expr, $varlist, $e) = @_;
 148
 149         my $x = new Parse::Pidl::Expr();
 150
 151         return $x->Run($expr, sub { my $x = shift; error($e, $x); },
 152                 # Lookup fn
 153                 sub { my $x = shift;
 154                           return($varlist->{$x}) if (defined($varlist->{$x}));
 155                           return $x;
 156                   },
 157                 undef, undef);
 158 }
 159
 160 =item B<ParseExprExt>
 161 Interpret an IDL expression, substituting particular variables. Can call
 162 callbacks when pointers are being dereferenced or variables are being used.
 163
 164 =cut
 165 sub ParseExprExt($$$$$)
 166 {
 167         my($expr, $varlist, $e, $deref, $use) = @_;
 168
 169         my $x = new Parse::Pidl::Expr();
 170
 171         return $x->Run($expr, sub { my $x = shift; error($e, $x); },
 172                 # Lookup fn
 173                 sub { my $x = shift;
 174                           return($varlist->{$x}) if (defined($varlist->{$x}));
 175                           return $x;
 176                   },
 177                 $deref, $use);
 178 }
 179
 180 =item B<genpad>
 181 return an empty string consisting of tabs and spaces suitable for proper indent
 182 of C-functions.
 183
 184 =cut
 185 sub genpad($)
 186 {
 187         my ($s) = @_;
 188         my $nt = int((length($s)+1)/8);
 189         my $lt = ($nt*8)-1;
 190         my $ns = (length($s)-$lt);
 191         return "\t"x($nt)." "x($ns);
 192 }
 193
 194 =item B<parse_int>
 195
 196 Try to convert hex and octal strings to numbers. If a string doesn't
 197 look hexish or octish it will be left as is. If the unconverted string
 198 is actually a decimal number, Perl is likely to handle it correctly.
 199
 200 =cut
 201
 202 sub parse_int {
 203         my $s = shift;
 204         if ($s =~ /^0[xX][0-9A-Fa-f]+$/) {
 205                 return hex $s;
 206         }
 207         if ($s =~ /^0[0-7]+$/) {
 208                 return oct $s;
 209         }
 210         return $s;
 211 }
 212
 213 =item B<parse_range>
 214
 215 Read a range specification that might contain hex or octal numbers,
 216 and work out what those numbers are.
 217
 218 =cut
 219
 220 sub parse_range {
 221         my $range = shift;
 222         my ($low, $high) = split(/,/, $range, 2);
 223         $low = parse_int($low);
 224         $high = parse_int($high);
 225         return ($low, $high);
 226 }
 227
 228
 229 =back
 230
 231 =cut
 232
 233 1;