release/src-rt-6.x.4708/router/samba-3.5.8/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;