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);
  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         $Data::Dumper::Sortkeys = 1;
  47         my $s = shift;
  48         return Data::Dumper::Dumper($s);
  49 }
  50
  51 =item B<has_property>
  52 see if a pidl property list contains a given property
  53
  54 =cut
  55 sub has_property($$)
  56 {
  57         my($e, $p) = @_;
  58
  59         return undef if (not defined($e->{PROPERTIES}));
  60
  61         return $e->{PROPERTIES}->{$p};
  62 }
  63
  64 =item B<property_matches>
  65 see if a pidl property matches a value
  66
  67 =cut
  68 sub property_matches($$$)
  69 {
  70         my($e,$p,$v) = @_;
  71
  72         if (!defined has_property($e, $p)) {
  73                 return undef;
  74         }
  75
  76         if ($e->{PROPERTIES}->{$p} =~ /$v/) {
  77                 return 1;
  78         }
  79
  80         return undef;
  81 }
  82
  83 =item B<is_constant>
  84 return 1 if the string is a C constant
  85
  86 =cut
  87 sub is_constant($)
  88 {
  89         my $s = shift;
  90         return 1 if ($s =~ /^\d+$/);
  91         return 1 if ($s =~ /^0x[0-9A-Fa-f]+$/);
  92         return 0;
  93 }
  94
  95 =item B<make_str>
  96 return a "" quoted string, unless already quoted
  97
  98 =cut
  99 sub make_str($)
 100 {
 101         my $str = shift;
 102         if (substr($str, 0, 1) eq "\"") {
 103                 return $str;
 104         }
 105         return "\"$str\"";
 106 }
 107
 108 =item B<unmake_str>
 109 unquote a "" quoted string
 110
 111 =cut
 112 sub unmake_str($)
 113 {
 114         my $str = shift;
 115
 116         $str =~ s/^\"(.*)\"$/$1/;
 117
 118         return $str;
 119 }
 120
 121 =item B<print_uuid>
 122 Print C representation of a UUID.
 123
 124 =cut
 125 sub print_uuid($)
 126 {
 127         my ($uuid) = @_;
 128         $uuid =~ s/"//g;
 129         my ($time_low,$time_mid,$time_hi,$clock_seq,$node) = split /-/, $uuid;
 130         return undef if not defined($node);
 131
 132         my @clock_seq = $clock_seq =~ /(..)/g;
 133         my @node = $node =~ /(..)/g;
 134
 135         return "{0x$time_low,0x$time_mid,0x$time_hi," .
 136                 "{".join(',', map {"0x$_"} @clock_seq)."}," .
 137                 "{".join(',', map {"0x$_"} @node)."}}";
 138 }
 139
 140 =item B<ParseExpr>
 141 Interpret an IDL expression, substituting particular variables.
 142
 143 =cut
 144 sub ParseExpr($$$)
 145 {
 146         my($expr, $varlist, $e) = @_;
 147
 148         my $x = new Parse::Pidl::Expr();
 149
 150         return $x->Run($expr, sub { my $x = shift; error($e, $x); },
 151                 # Lookup fn
 152                 sub { my $x = shift;
 153                           return($varlist->{$x}) if (defined($varlist->{$x}));
 154                           return $x;
 155                   },
 156                 undef, undef);
 157 }
 158
 159 =item B<ParseExprExt>
 160 Interpret an IDL expression, substituting particular variables. Can call
 161 callbacks when pointers are being dereferenced or variables are being used.
 162
 163 =cut
 164 sub ParseExprExt($$$$$)
 165 {
 166         my($expr, $varlist, $e, $deref, $use) = @_;
 167
 168         my $x = new Parse::Pidl::Expr();
 169
 170         return $x->Run($expr, sub { my $x = shift; error($e, $x); },
 171                 # Lookup fn
 172                 sub { my $x = shift;
 173                           return($varlist->{$x}) if (defined($varlist->{$x}));
 174                           return $x;
 175                   },
 176                 $deref, $use);
 177 }
 178
 179 =item B<genpad>
 180 return an empty string consisting of tabs and spaces suitable for proper indent
 181 of C-functions.
 182
 183 =cut
 184 sub genpad($)
 185 {
 186         my ($s) = @_;
 187         my $nt = int((length($s)+1)/8);
 188         my $lt = ($nt*8)-1;
 189         my $ns = (length($s)-$lt);
 190         return "\t"x($nt)." "x($ns);
 191 }
 192
 193 =back
 194
 195 =cut
 196
 197 1;