File Coverage

blib/lib/Parse/Win32Registry/Base.pm
Criterion Covered Total %
statement 427 496 86.0
branch 178 218 81.6
condition 62 94 65.9
subroutine 69 76 90.7
pod 0 18 0.0
total 736 902 81.6


line stmt bran cond sub pod time code
1             package Parse::Win32Registry::Base;
2              
3 13     13   97 use strict;
  13         28  
  13         394  
4 13     13   74 use warnings;
  13         25  
  13         366  
5              
6 13     13   78 use base qw(Exporter);
  13         25  
  13         1376  
7              
8 13     13   84 use Carp;
  13         41  
  13         764  
9 13     13   80 use Encode;
  13         35  
  13         922  
10 13     13   6124 use Time::Local qw(timegm);
  13         27898  
  13         1526  
11              
12             our @EXPORT_OK = qw(
13             warnf
14             iso8601
15             hexdump
16             format_octets
17             unpack_windows_time
18             unpack_string
19             unpack_unicode_string
20             unpack_guid
21             unpack_sid
22             unpack_ace
23             unpack_acl
24             unpack_security_descriptor
25             unpack_series
26             make_multiple_subkey_iterator
27             make_multiple_value_iterator
28             make_multiple_subtree_iterator
29             compare_multiple_keys
30             compare_multiple_values
31             REG_NONE
32             REG_SZ
33             REG_EXPAND_SZ
34             REG_BINARY
35             REG_DWORD
36             REG_DWORD_BIG_ENDIAN
37             REG_LINK
38             REG_MULTI_SZ
39             REG_RESOURCE_LIST
40             REG_FULL_RESOURCE_DESCRIPTOR
41             REG_RESOURCE_REQUIREMENTS_LIST
42             REG_QWORD
43             );
44              
45             our %EXPORT_TAGS = (
46             all => [@EXPORT_OK],
47             );
48              
49 13     13   102 use constant REG_NONE => 0;
  13         25  
  13         696  
50 13     13   85 use constant REG_SZ => 1;
  13         36  
  13         630  
51 13     13   83 use constant REG_EXPAND_SZ => 2;
  13         25  
  13         632  
52 13     13   82 use constant REG_BINARY => 3;
  13         24  
  13         681  
53 13     13   93 use constant REG_DWORD => 4;
  13         40  
  13         663  
54 13     13   85 use constant REG_DWORD_BIG_ENDIAN => 5;
  13         24  
  13         779  
55 13     13   108 use constant REG_LINK => 6;
  13         26  
  13         690  
56 13     13   83 use constant REG_MULTI_SZ => 7;
  13         23  
  13         698  
57 13     13   85 use constant REG_RESOURCE_LIST => 8;
  13         25  
  13         656  
58 13     13   184 use constant REG_FULL_RESOURCE_DESCRIPTOR => 9;
  13         142  
  13         758  
59 13     13   83 use constant REG_RESOURCE_REQUIREMENTS_LIST => 10;
  13         27  
  13         672  
60 13     13   75 use constant REG_QWORD => 11;
  13         23  
  13         36764  
61              
62             our $WARNINGS = 0;
63              
64             our $CODEPAGE = 'cp1252';
65              
66             sub warnf {
67 455     455 0 750 my $message = shift;
68 455 100       1471 warn sprintf "$message\n", @_ if $WARNINGS;
69             }
70              
71             sub hexdump {
72 40     40 0 186 my $data = shift; # packed binary data
73 40   100     110 my $start = shift || 0; # starting value for displayed offset
74              
75 40 100       91 return '' if !defined($data);
76              
77 39         60 my $output = '';
78              
79 39         64 my $fake_start = $start & ~0xf;
80 39         64 my $end = length($data);
81              
82 39         100 my $pos = 0;
83 39 100       88 if ($fake_start < $start) {
84 30         128 $output .= sprintf '%8x ', $fake_start;
85 30         55 my $indent = $start - $fake_start;
86 30         95 $output .= ' ' x $indent;
87 30         65 my $row = substr($data, $pos, 16 - $indent);
88 30         44 my $len = length($row);
89 30         152 $output .= join(' ', unpack('H2' x $len, $row));
90 30 100       88 if ($indent + $len < 16) {
91 11         16 my $padding = 16 - $len - $indent;
92 11         24 $output .= ' ' x $padding;
93             }
94 30         51 $output .= ' ';
95 30         57 $output .= ' ' x $indent;
96 30         55 $row =~ tr/\x20-\x7e/./c;
97 30         50 $output .= $row;
98 30         50 $output .= "\n";
99 30         42 $pos += $len;
100             }
101 39         92 while ($pos < $end) {
102 68         168 $output .= sprintf '%8x ', $start + $pos;
103 68         129 my $row = substr($data, $pos, 16);
104 68         94 my $len = length($row);
105 68         313 $output .= join(' ', unpack('H2' x $len, $row));
106 68 100       177 if ($len < 16) {
107 24         43 my $padding = 16 - $len;
108 24         48 $output .= ' ' x $padding;
109             }
110 68         102 $output .= ' ';
111 68         107 $row =~ tr/\x20-\x7e/./c;
112 68         112 $output .= $row;
113 68         94 $output .= "\n";
114 68         137 $pos += 16;
115             }
116              
117 39         185 return $output;
118             }
119              
120             sub format_octets {
121 70     70 0 164 my $data = shift; # packed binary data
122 70   100     211 my $col = shift || 0; # starting column, e.g. length of initial string
123              
124 70 100       192 return "\n" if !defined($data);
125              
126 68         127 my $output = '';
127              
128 68 100       185 $col = 76 if $col > 76;
129 68         242 my $max_octets = int((76 - $col) / 3) + 1;
130              
131 68         126 my $end = length($data);
132 68         111 my $pos = 0;
133 68         120 my $num_octets = $end - $pos;
134 68 100       161 $num_octets = $max_octets if $num_octets > $max_octets;
135 68         163 while ($pos < $end) {
136 105         674 $output .= join(',', unpack("x$pos(H2)$num_octets", $data));
137 105         251 $pos += $num_octets;
138 105         158 $num_octets = $end - $pos;
139 105 100       237 $num_octets = 25 if $num_octets > 25;
140 105 100       248 if ($num_octets > 0) {
141 46         108 $output .= ",\\\n ";
142             }
143             }
144 68         138 $output .= "\n";
145 68         291 return $output;
146             }
147              
148             sub unpack_windows_time {
149 535     535 0 13223 my $data = shift;
150              
151 535 50       1234 if (!defined $data) {
152 0         0 return;
153             }
154              
155 535 100       1242 if (length($data) < 8) {
156 2         7 return;
157             }
158              
159             # The conversion uses real numbers
160             # as 32-bit perl does not provide 64-bit integers.
161             # The equation can be found in several places on the Net.
162             # My thanks go to Dan Sully for Audio::WMA's _fileTimeToUnixTime
163             # which shows a perl implementation of it.
164 533         1598 my ($low, $high) = unpack("VV", $data);
165 533         1149 my $filetime = $high * 2 ** 32 + $low;
166 533         1351 my $epoch_time = int(($filetime - 116444736000000000) / 10000000);
167              
168             # adjust the UNIX epoch time to the local OS's epoch time
169             # (see perlport's Time and Date section)
170 533         1493 my $epoch_offset = timegm(0, 0, 0, 1, 0, 1970);
171 533         13900 $epoch_time += $epoch_offset;
172              
173 533 100 100     2037 if ($epoch_time < 0 || $epoch_time > 0x7fffffff) {
174 8         13 $epoch_time = undef;
175             }
176              
177 533 100       1651 return wantarray ? ($epoch_time, 8) : $epoch_time;
178             }
179              
180             sub iso8601 {
181 138     138 0 30106 my $time = shift;
182 138         219 my $tz = shift;
183              
184 138 100       394 if (!defined $time) {
185 40         195 return '(undefined)';
186             }
187              
188 98 50 33     277 if (!defined $tz || $tz ne 'Z') {
189 98         161 $tz = 'Z'
190             }
191              
192             # On Windows, gmtime will return undef if $time < 0 or > 0x7fffffff
193 98 50 33     640 if ($time < 0 || $time > 0x7fffffff) {
194 0         0 return '(undefined)';
195             }
196 98         544 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday) = gmtime $time;
197              
198             # The final 'Z' indicates UTC ("zero meridian")
199 98         889 return sprintf '%04d-%02d-%02dT%02d:%02d:%02d%s',
200             1900+$year, 1+$mon, $mday, $hour, $min, $sec, $tz;
201             }
202              
203             sub unpack_string {
204 12     12 0 8326 my $data = shift;
205              
206 12 50       35 if (!defined $data) {
207 0         0 return;
208             }
209              
210 12         24 my $str;
211             my $str_len;
212 12 100       37 if ((my $end = index($data, "\0")) != -1) {
213 8         16 $str = substr($data, 0, $end);
214 8         16 $str_len = $end + 1; # include the final null in the length
215             }
216             else {
217 4         7 $str = $data;
218 4         6 $str_len = length($data);
219             }
220              
221 12 100       39 return wantarray ? ($str, $str_len) : $str;
222             }
223              
224             sub unpack_unicode_string {
225 22     22 0 17540 my $data = shift;
226              
227 22 50       58 if (!defined $data) {
228 0         0 return;
229             }
230              
231 22         36 my $str_len = 0;
232 22         60 foreach my $v (unpack('v*', $data)) {
233 70         88 $str_len += 2;
234 70 100       134 last if $v == 0; # include the final null in the length
235             }
236 22         78 my $str = decode('UCS-2LE', substr($data, 0, $str_len));
237              
238             # The decode function from Encode may create invalid unicode characters
239             # which cause subsequent warnings (e.g. during regex matching).
240             # For example, characters in the 0xd800 to 0xdfff range of the
241             # basic multilingual plane (0x0000 to 0xffff) are 'surrogate pairs'
242             # and are expected to appear as a 'high surrogate' (0xd800 to 0xdbff)
243             # followed by a 'low surrogate' (0xdc00 to 0xdfff).
244              
245             # remove any final null
246 22 100 100     4128 if (length($str) > 0 && substr($str, -1, 1) eq "\0") {
247 12         25 chop $str;
248             }
249              
250 22 100       83 return wantarray ? ($str, $str_len) : $str;
251             }
252              
253             sub unpack_guid {
254 8     8 0 4387 my $guid = Parse::Win32Registry::GUID->new($_[0]);
255 8 100       20 return if !defined $guid;
256 6 100       23 return wantarray ? ($guid, $guid->get_length) : $guid;
257             }
258              
259             sub unpack_sid {
260 14     14 0 5530 my $sid = Parse::Win32Registry::SID->new($_[0]);
261 14 100       36 return if !defined $sid;
262 8 100       26 return wantarray ? ($sid, $sid->get_length) : $sid;
263             }
264              
265             sub unpack_ace {
266 22     22 0 8153 my $ace = Parse::Win32Registry::ACE->new($_[0]);
267 22 100       65 return if !defined $ace;
268 10 100       33 return wantarray ? ($ace, $ace->get_length) : $ace;
269             }
270              
271             sub unpack_acl {
272 22     22 0 9246 my $acl = Parse::Win32Registry::ACL->new($_[0]);
273 22 100       53 return if !defined $acl;
274 10 100       31 return wantarray ? ($acl, $acl->get_length) : $acl;
275             }
276              
277             sub unpack_security_descriptor {
278 37     37 0 11765 my $sd = Parse::Win32Registry::SecurityDescriptor->new($_[0]);
279 37 100       92 return if !defined $sd;
280 26 100       88 return wantarray ? ($sd, $sd->get_length) : $sd;
281             }
282              
283             sub unpack_series {
284 0     0 0 0 my $function = shift;
285 0         0 my $data = shift;
286              
287 0 0 0     0 if (!defined $function || !defined $data) {
288 0         0 croak "Usage: unpack_series(\\\&unpack_function, \$data)";
289             }
290              
291 0         0 my $pos = 0;
292 0         0 my @items = ();
293 0         0 while (my ($item, $item_len) = $function->(substr($data, $pos))) {
294 0         0 push @items, $item;
295 0         0 $pos += $item_len;
296             }
297 0         0 return @items;
298             }
299              
300             sub make_multiple_subkey_iterator {
301 41     41 0 1539 my @keys = @_;
302              
303             # check @keys contains keys
304 41 100 66     127 if (@keys == 0 ||
305 64 100       426 grep { defined && !UNIVERSAL::isa($_, 'Parse::Win32Registry::Key') }
306             @keys) {
307 1         100 croak 'Usage: make_multiple_subkey_iterator($key1, $key2, ...)';
308             }
309              
310 40         85 my %subkeys_seen = ();
311 40         61 my @subkeys_queue;
312 40         117 for (my $i = 0; $i < @keys; $i++) {
313 64         98 my $key = $keys[$i];
314 64 100       135 next if !defined $key;
315 56         197 foreach my $subkey ($key->get_list_of_subkeys) {
316 46         141 my $name = $subkey->get_name;
317 46         180 $subkeys_seen{$name}[$i] = $subkey;
318             }
319             }
320 40         167 foreach my $name (sort keys %subkeys_seen) {
321             # make sure number of subkeys matches number of keys
322 34 100       54 if (@{$subkeys_seen{$name}} != @keys) {
  34         87  
323 2         12 @{$subkeys_seen{$name}}[@keys - 1] = undef;
  2         6  
324             }
325 34         76 push @subkeys_queue, $subkeys_seen{$name};
326             }
327              
328             return Parse::Win32Registry::Iterator->new(sub {
329 68     68   103 my $subkeys = shift @subkeys_queue;
330 68 100       134 if (defined $subkeys) {
331 34         101 return $subkeys;
332             }
333             else {
334 34         130 return;
335             }
336 40         177 });
337             }
338              
339             sub make_multiple_value_iterator {
340 41     41 0 1025 my @keys = @_;
341              
342             # check @keys contains keys
343 41 100 66     130 if (@keys == 0 ||
344 64 100       345 grep { defined && !UNIVERSAL::isa($_, 'Parse::Win32Registry::Key') }
345             @keys) {
346 1         94 croak 'Usage: make_multiple_value_iterator($key1, $key2, ...)';
347             }
348              
349 40         79 my %values_seen = ();
350 40         55 my @values_queue;
351 40         111 for (my $i = 0; $i < @keys; $i++) {
352 64         105 my $key = $keys[$i];
353 64 100       139 next if !defined $key;
354 56         154 foreach my $value ($key->get_list_of_values) {
355 74         191 my $name = $value->get_name;
356 74         288 $values_seen{$name}[$i] = $value;
357             }
358             }
359 40         160 foreach my $name (sort keys %values_seen) {
360             # make sure number of values matches number of keys
361 62 100       92 if (@{$values_seen{$name}} != @keys) {
  62         154  
362 2         6 @{$values_seen{$name}}[@keys - 1] = undef;
  2         12  
363             }
364 62         132 push @values_queue, $values_seen{$name};
365             }
366              
367             return Parse::Win32Registry::Iterator->new(sub {
368 60     60   114 my $values = shift @values_queue;
369 60 100       134 if (defined $values) {
370 36         78 return $values;
371             }
372             else {
373 24         53 return;
374             }
375 40         171 });
376             }
377              
378             sub make_multiple_subtree_iterator {
379 7     7 0 2960 my @keys = @_;
380              
381             # check @keys contains keys
382 7 100 66     40 if (@keys == 0 ||
383 10 50       82 grep { defined && !UNIVERSAL::isa($_, 'Parse::Win32Registry::Key') }
384             @keys) {
385 1         96 croak 'Usage: make_multiple_subtree_iterator($key1, $key2, ...)';
386             }
387              
388 6         26 my @start_keys = (\@keys);
389             push my (@subkey_iters), Parse::Win32Registry::Iterator->new(sub {
390 10     10   23 return shift @start_keys;
391 6         40 });
392 6         17 my $value_iter;
393             my $subkeys; # used to remember subkeys while iterating values
394              
395             return Parse::Win32Registry::Iterator->new(sub {
396 80 100 100 80   404 if (defined $value_iter && wantarray) {
397 60         132 my $values = $value_iter->();
398 60 100       136 if (defined $values) {
399 36         100 return ($subkeys, $values);
400             }
401             }
402 44         108 while (@subkey_iters > 0) {
403 78         169 $subkeys = $subkey_iters[-1]->(); # depth-first
404 78 100       160 if (defined $subkeys) {
405 40         108 push @subkey_iters, make_multiple_subkey_iterator(@$subkeys);
406 40         99 $value_iter = make_multiple_value_iterator(@$subkeys);
407 40         142 return $subkeys;
408             }
409 38         139 pop @subkey_iters; # iter finished, so remove it
410             }
411 4         16 return;
412 6         33 });
413             }
414              
415             sub compare_multiple_keys {
416 13     13 0 8280 my @keys = @_;
417              
418             # check @keys contains keys
419 13 100 66     52 if (@keys == 0 ||
420 36 100       163 grep { defined && !UNIVERSAL::isa($_, 'Parse::Win32Registry::Key') }
421             @keys) {
422 1         135 croak 'Usage: compare_multiple_keys($key1, $key2, ...)';
423             }
424              
425 12         21 my @changes = ();
426              
427 12         21 my $benchmark_key;
428 12         21 foreach my $key (@keys) {
429 36         51 my $diff = '';
430             # Skip comparison for the first value
431 36 100       70 if (@changes > 0) {
432 24         49 $diff = _compare_keys($benchmark_key, $key);
433             }
434 36         55 $benchmark_key = $key;
435 36         71 push @changes, $diff;
436             }
437 12         71 return @changes;
438             }
439              
440             sub compare_multiple_values {
441 11     11 0 6791 my @values = @_;
442              
443             # check @values contains values
444 11 100 66     50 if (@values == 0 ||
445 30 100       135 grep { defined && !UNIVERSAL::isa($_, 'Parse::Win32Registry::Value') }
446             @values) {
447 1         95 croak 'Usage: compare_multiple_values($value1, $value2, ...)';
448             }
449              
450 10         19 my @changes = ();
451              
452 10         14 my $benchmark_value;
453 10         18 foreach my $value (@values) {
454 30         44 my $diff = '';
455             # Skip comparison for the first value
456 30 100       57 if (@changes > 0) {
457 20         40 $diff = _compare_values($benchmark_value, $value);
458             }
459 30         46 $benchmark_value = $value;
460 30         59 push @changes, $diff;
461             }
462 10         57 return @changes;
463             }
464              
465             sub _compare_keys {
466 24     24   42 my ($key1, $key2) = @_;
467              
468 24 100 100     127 if (!defined $key1 && !defined $key2) {
    100 100        
    100 66        
469 4         10 return ''; # 'MISSING'
470             }
471             elsif (defined $key1 && !defined $key2) {
472 2         5 return 'DELETED';
473             }
474             elsif (!defined $key1 && defined $key2) {
475 2         8 return 'ADDED';
476             }
477              
478 16         37 my $timestamp1 = $key1->get_timestamp;
479 16         35 my $timestamp2 = $key2->get_timestamp;
480 16 50 66     40 if ($key1->get_name ne $key2->get_name) {
    100          
481 0         0 return 'CHANGED';
482             }
483             elsif (defined $timestamp1 && defined $timestamp2) {
484 8 50       30 if ($timestamp1 < $timestamp2) {
    50          
485 0         0 return 'NEWER';
486             }
487             elsif ($timestamp1 > $timestamp2) {
488 0         0 return 'OLDER';
489             }
490             }
491             else {
492 8         20 return ''; # comment out to check values...
493 0         0 my $value_iter = make_multiple_value_iterator($key1, $key2);
494 0         0 while (my ($val1, $val2) = $value_iter->get_next) {
495 0 0       0 if (_compare_values($val1, $val2) ne '') {
496 0         0 return 'VALUES';
497             }
498             }
499 0         0 return '';
500             }
501             }
502              
503             sub _compare_values {
504 20     20   39 my ($val1, $val2) = @_;
505              
506 20 100 100     96 if (!defined $val1 && !defined $val2) {
    100 100        
    100 66        
507 4         10 return ''; # 'MISSING'
508             }
509             elsif (defined $val1 && !defined $val2) {
510 2         5 return 'DELETED';
511             }
512             elsif (!defined $val1 && defined $val2) {
513 2         4 return 'ADDED';
514             }
515              
516 12         35 my $data1 = $val1->get_data;
517 12         29 my $data2 = $val2->get_data;
518 12 50 33     27 if ($val1->get_name ne $val2->get_name ||
      33        
      33        
      33        
      33        
519             $val1->get_type != $val2->get_type ||
520             defined $data1 ne defined $data2 ||
521             (defined $data1 && defined $data2 && $data1 ne $data2)) {
522 0         0 return 'CHANGED';
523             }
524             else {
525 12         33 return '';
526             }
527             }
528              
529              
530             package Parse::Win32Registry::Iterator;
531              
532 13     13   115 use Carp;
  13         35  
  13         16902  
533              
534             sub new {
535 744     744   1557 my $class = shift;
536 744         1128 my $self = shift;
537              
538 744         1453 my $type = ref $self;
539 744 50 33     1956 croak 'Missing iterator subroutine' if $type ne 'CODE'
540             && $type ne __PACKAGE__;
541              
542 744         1302 bless $self, $class;
543 744         2494 return $self;
544             }
545              
546             sub get_next {
547 138     138   72692 $_[0]->();
548             }
549              
550              
551             package Parse::Win32Registry::GUID;
552              
553             sub new {
554 8     8   14 my $class = shift;
555 8         13 my $data = shift;
556              
557 8 50       18 if (!defined $data) {
558 0         0 return;
559             }
560              
561 8 100       21 if (length($data) < 16) {
562 2         5 return;
563             }
564              
565 6         43 my $guid = sprintf '{%08X-%04X-%04X-%02X%02X-%02X%02X%02X%02X%02X%02X}',
566             unpack('VvvC2C6', $data);
567              
568 6         21 my $self = {
569             _guid => $guid,
570             _length => 16,
571             };
572 6         11 bless $self, $class;
573              
574 6         13 return $self;
575             }
576              
577             sub as_string {
578 6     6   3371 my $self = shift;
579              
580 6         28 return $self->{_guid};
581             }
582              
583             sub get_length {
584 3     3   5 my $self = shift;
585              
586 3         15 return $self->{_length};
587             }
588              
589              
590             package Parse::Win32Registry::SID;
591              
592             sub new {
593 170     170   283 my $class = shift;
594 170         320 my $data = shift;
595              
596 170 50       337 if (!defined $data) {
597 0         0 return;
598             }
599              
600             # 0x00 byte = revision
601             # 0x01 byte = number of sub authorities
602             # 0x07 byte = identifier authority
603             # 0x08 dword = 1st sub authority
604             # 0x0c dword = 2nd sub authority
605             # ...
606              
607 170 100       365 if (length($data) < 8) {
608 4         8 return;
609             }
610              
611 166         397 my ($rev, $num_sub_auths, $id_auth) = unpack('CCx5C', $data);
612              
613 166 100       350 if ($num_sub_auths == 0) {
614 2         5 return;
615             }
616              
617 164         287 my $sid_len = 8 + 4 * $num_sub_auths;
618              
619 164 100       298 if (length($data) < $sid_len) {
620 8         17 return;
621             }
622              
623 156         376 my @sub_auths = unpack("x8V$num_sub_auths", $data);
624 156         515 my $sid = "S-$rev-$id_auth-" . join('-', @sub_auths);
625              
626 156         449 my $self = {
627             _sid => $sid,
628             _length => $sid_len,
629             };
630 156         359 bless $self, $class;
631              
632 156         385 return $self;
633             }
634              
635             # See KB243330 for a list of well known sids
636             our %WellKnownSids = (
637             'S-1-0-0' => 'Nobody',
638             'S-1-1-0' => 'Everyone',
639             'S-1-3-0' => 'Creator Owner',
640             'S-1-3-1' => 'Creator Group',
641             'S-1-3-2' => 'Creator Owner Server',
642             'S-1-3-3' => 'Creator Group Server',
643             'S-1-5-1' => 'Dialup',
644             'S-1-5-2' => 'Network',
645             'S-1-5-3' => 'Batch',
646             'S-1-5-4' => 'Interactive',
647             'S-1-5-5-\\d+-\\d+' => 'Logon Session',
648             'S-1-5-6' => 'Service',
649             'S-1-5-7' => 'Anonymous',
650             'S-1-5-8' => 'Proxy',
651             'S-1-5-9' => 'Enterprise Domain Controllers',
652             'S-1-5-10' => 'Principal Self',
653             'S-1-5-11' => 'Authenticated Users',
654             'S-1-5-12' => 'Restricted Code',
655             'S-1-5-13' => 'Terminal Server Users',
656             'S-1-5-18' => 'Local System',
657             'S-1-5-19' => 'Local Service',
658             'S-1-5-20' => 'Network Service',
659             'S-1-5-\\d+-\\d+-\\d+-\\d+-500' => 'Administrator',
660             'S-1-5-\\d+-\\d+-\\d+-\\d+-501' => 'Guest',
661             'S-1-5-\\d+-\\d+-\\d+-\\d+-502' => 'KRBTGT',
662             'S-1-5-\\d+-\\d+-\\d+-\\d+-512' => 'Domain Admins',
663             'S-1-5-\\d+-\\d+-\\d+-\\d+-513' => 'Domain Users',
664             'S-1-5-\\d+-\\d+-\\d+-\\d+-514' => 'Domain Guests',
665             'S-1-5-\\d+-\\d+-\\d+-\\d+-515' => 'Domain Computers',
666             'S-1-5-\\d+-\\d+-\\d+-\\d+-516' => 'Domain Controllers',
667             'S-1-5-\\d+-\\d+-\\d+-\\d+-517' => 'Cert Publishers',
668             'S-1-5-\\d+-\\d+-\\d+-\\d+-518' => 'Schema Admins',
669             'S-1-5-\\d+-\\d+-\\d+-\\d+-519' => 'Enterprise Admins',
670             'S-1-5-\\d+-\\d+-\\d+-\\d+-520' => 'Group Policy Creator Owners',
671             'S-1-5-\\d+-\\d+-\\d+-\\d+-533' => 'RAS and IAS Servers',
672             'S-1-5-32-544' => 'Administrators',
673             'S-1-5-32-545' => 'Users',
674             'S-1-5-32-546' => 'Guest',
675             'S-1-5-32-547' => 'Power Users',
676             'S-1-5-32-548' => 'Account Operators',
677             'S-1-5-32-549' => 'Server Operators',
678             'S-1-5-32-550' => 'Print Operators',
679             'S-1-5-32-551' => 'Backup Operators',
680             'S-1-5-32-552' => 'Replicators',
681             'S-1-16-4096' => 'Low Integrity Level',
682             'S-1-16-8192' => 'Medium Integrity Level',
683             'S-1-16-12288' => 'High Integrity Level',
684             'S-1-16-16384' => 'System Integrity Level',
685             );
686              
687             sub get_name {
688 0     0   0 my $self = shift;
689              
690 0         0 my $sid = $self->{_sid};
691              
692 0         0 foreach my $regexp (keys %WellKnownSids) {
693 0 0       0 if ($sid =~ m/^$regexp$/) {
694 0         0 return $WellKnownSids{$regexp};
695             }
696             }
697 0         0 return;
698             }
699              
700             sub as_string {
701 131     131   41217 my $self = shift;
702              
703 131         567 return $self->{_sid};
704             }
705              
706             sub get_length {
707 192     192   272 my $self = shift;
708              
709 192         475 return $self->{_length};
710             }
711              
712              
713             package Parse::Win32Registry::ACE;
714              
715             sub new {
716 129     129   210 my $class = shift;
717 129         266 my $data = shift;
718              
719 129 50       265 if (!defined $data) {
720 0         0 return;
721             }
722              
723             # 0x00 byte = type
724             # 0x01 byte = flags
725             # 0x02 word = length
726              
727             # Types:
728             # ACCESS_ALLOWED_ACE_TYPE = 0
729             # ACCESS_DENIED_ACE_TYPE = 1
730             # SYSTEM_AUDIT_ACE_TYPE = 2
731             # SYSTEM_MANDATORY_LABEL_ACE_TYPE = x011
732              
733             # Flags:
734             # OBJECT_INHERIT_ACE = 0x01
735             # CONTAINER_INHERIT_ACE = 0x02
736             # NO_PROPAGATE_INHERIT_ACE = 0x04
737             # INHERIT_ONLY_ACE = 0x08
738             # INHERITED_ACE = 0x10
739             # SUCCESSFUL_ACCESS_ACE_FLAG = 0x40 (Audit Success)
740             # FAILED_ACCESS_ACE_FLAG = 0x80 (Audit Failure)
741              
742 129 100       258 if (length($data) < 4) {
743 6         11 return;
744             }
745              
746 123         284 my ($type, $flags, $ace_len) = unpack('CCv', $data);
747              
748 123 100       267 if (length($data) < $ace_len) {
749 6         17 return;
750             }
751              
752             # The data following the header varies depending on the type.
753             # For ACCESS_ALLOWED_ACE, ACCESS_DENIED_ACE, SYSTEM_AUDIT_ACE
754             # the header is followed by an access mask and a sid.
755             # 0x04 dword = access mask
756             # 0x08 = SID
757              
758             # Only the following types are currently unpacked:
759             # 0 (ACCESS_ALLOWED_ACE), 1 (ACCESS_DENIED_ACE), 2 (SYSTEM_AUDIT_ACE)
760 117 100 66     512 if ($type >= 0 && $type <= 2 || $type == 0x11) {
      100        
761 112         211 my $access_mask = unpack('x4V', $data);
762 112         293 my $sid = Parse::Win32Registry::SID->new(substr($data, 8,
763             $ace_len - 8));
764              
765             # Abandon ace if sid is invalid
766 112 100       265 if (!defined $sid) {
767 4         9 return;
768             }
769              
770             # Abandon ace if not the expected length
771 108 100       215 if (($sid->get_length + 8) != $ace_len) {
772 2         6 return;
773             }
774              
775 106         336 my $self = {
776             _type => $type,
777             _flags => $flags,
778             _mask => $access_mask,
779             _trustee => $sid,
780             _length => $ace_len,
781             };
782 106         182 bless $self, $class;
783              
784 106         229 return $self;
785             }
786             else {
787 5         15 return;
788             }
789             }
790              
791             our @Types = qw(
792             ACCESS_ALLOWED
793             ACCESS_DENIED
794             SYSTEM_AUDIT
795             SYSTEM_ALARM
796             ALLOWED_COMPOUND
797             ACCESS_ALLOWED_OBJECT
798             ACCESS_DENIED_OBJECT
799             SYSTEM_AUDIT_OBJECT
800             SYSTEM_ALARM_OBJECT
801             ACCESS_ALLOWED_CALLBACK
802             ACCESS_DENIED_CALLBACK
803             ACCESS_ALLOWED_CALLBACK_OBJECT
804             ACCESS_DENIED_CALLBACK_OBJECT
805             SYSTEM_AUDIT_CALLBACK
806             SYSTEM_ALARM_CALLBACK
807             SYSTEM_AUDIT_CALLBACK_OBJECT
808             SYSTEM_ALARM_CALLBACK_OBJECT
809             SYSTEM_MANDATORY_LABEL
810             );
811              
812             sub _look_up_ace_type {
813 97     97   166 my $type = shift;
814              
815 97 50       233 if (exists $Types[$type]) {
816 97         460 return $Types[$type];
817             }
818             else {
819 0         0 return '';
820             }
821             }
822              
823             sub get_type {
824 97     97   78856 return $_[0]->{_type};
825             }
826              
827             sub get_type_as_string {
828 97     97   255 return _look_up_ace_type($_[0]->{_type});
829             }
830              
831             sub get_flags {
832 97     97   431 return $_[0]->{_flags};
833             }
834              
835             sub get_access_mask {
836 97     97   439 return $_[0]->{_mask};
837             }
838              
839             sub get_trustee {
840 97     97   403 return $_[0]->{_trustee};
841             }
842              
843             sub as_string {
844 0     0   0 my $self = shift;
845              
846 0         0 my $sid = $self->{_trustee};
847             my $string = sprintf '%s 0x%02x 0x%08x %s',
848             _look_up_ace_type($self->{_type}),
849             $self->{_flags},
850             $self->{_mask},
851 0         0 $sid->as_string;
852 0         0 my $name = $sid->get_name;
853 0 0       0 $string .= " [$name]" if defined $name;
854 0         0 return $string;
855             }
856              
857             sub get_length {
858 101     101   156 my $self = shift;
859              
860 101         264 return $self->{_length};
861             }
862              
863              
864             package Parse::Win32Registry::ACL;
865              
866 13     13   111 use Carp;
  13         31  
  13         5278  
867              
868             sub new {
869 51     51   89 my $class = shift;
870 51         97 my $data = shift;
871              
872 51 50       115 if (!defined $data) {
873 0         0 return;
874             }
875              
876             # 0x00 byte = revision
877             # 0x01
878             # 0x02 word = length
879             # 0x04 word = number of aces
880             # 0x06
881             # 0x08 = first ace (variable length)
882             # ... = second ace (variable length)
883             # ...
884              
885 51 100       105 if (length($data) < 8) {
886 2         5 return;
887             }
888              
889 49         144 my ($rev, $acl_len, $num_aces) = unpack('Cxvv', $data);
890              
891 49 100       122 if (length($data) < $acl_len) {
892 4         9 return;
893             }
894              
895 45         66 my $pos = 8;
896 45         81 my @acl = ();
897 45         109 foreach (my $num = 0; $num < $num_aces; $num++) {
898 107         296 my $ace = Parse::Win32Registry::ACE->new(substr($data, $pos,
899             $acl_len - $pos));
900             # Abandon acl if any single ace is undefined
901 107 100       277 return if !defined $ace;
902 96         171 push @acl, $ace;
903 96         170 $pos += $ace->get_length;
904             }
905              
906             # Abandon acl if not expected length, but don't use
907             # $pos != $acl_len as some acls contain unused space.
908 34 50       74 if ($pos > $acl_len) {
909 0         0 return;
910             }
911              
912 34         90 my $self = {
913             _acl => \@acl,
914             _length => $acl_len,
915             };
916 34         63 bless $self, $class;
917              
918 34         66 return $self;
919             }
920              
921             sub get_list_of_aces {
922 31     31   11741 my $self = shift;
923              
924 31         55 return @{$self->{_acl}};
  31         100  
925             }
926              
927             sub as_string {
928 0     0   0 croak 'Usage: ACLs do not have an as_string method; use as_stanza instead';
929             }
930              
931             sub as_stanza {
932 0     0   0 my $self = shift;
933              
934 0         0 my $stanza = '';
935 0         0 foreach my $ace (@{$self->{_acl}}) {
  0         0  
936 0         0 $stanza .= 'ACE: '. $ace->as_string . "\n";
937             }
938 0         0 return $stanza;
939             }
940              
941             sub get_length {
942 35     35   56 my $self = shift;
943              
944 35         90 return $self->{_length};
945             }
946              
947              
948             package Parse::Win32Registry::SecurityDescriptor;
949              
950 13     13   169 use Carp;
  13         33  
  13         10971  
951              
952             sub new {
953 37     37   73 my $class = shift;
954 37         59 my $data = shift;
955              
956 37 50       92 if (!defined $data) {
957 0         0 return;
958             }
959              
960             # Unpacks "self-relative" security descriptors
961              
962             # 0x00 word = revision
963             # 0x02 word = control flags
964             # 0x04 dword = offset to owner sid
965             # 0x08 dword = offset to group sid
966             # 0x0c dword = offset to sacl
967             # 0x10 dword = offset to dacl
968              
969             # Offsets are relative to the start of the security descriptor
970              
971             # Control Flags:
972             # SE_OWNER_DEFAULTED 0x0001
973             # SE_GROUP_DEFAULTED 0x0002
974             # SE_DACL_PRESENT 0x0004
975             # SE_DACL_DEFAULTED 0x0008
976             # SE_SACL_PRESENT 0x0010
977             # SE_SACL_DEFAULTED 0x0020
978             # SE_DACL_AUTO_INHERIT_REQ 0x0100
979             # SE_SACL_AUTO_INHERIT_REQ 0x0200
980             # SE_DACL_AUTO_INHERITED 0x0400
981             # SE_SACL_AUTO_INHERITED 0x0800
982             # SE_DACL_PROTECTED 0x1000
983             # SE_SACL_PROTECTED 0x2000
984             # SE_RM_CONTROL_VALID 0x4000
985             # SE_SELF_RELATIVE 0x8000
986              
987 37 100       88 if (length($data) < 20) {
988 2         6 return;
989             }
990              
991 35         136 my ($rev,
992             $flags,
993             $offset_to_owner,
994             $offset_to_group,
995             $offset_to_sacl,
996             $offset_to_dacl) = unpack('vvVVVV', $data);
997              
998 35         71 my %sd = ();
999 35         54 my $sd_len = 20;
1000              
1001 35         62 my $self = {};
1002 35 100 66     160 if ($offset_to_owner > 0 && $offset_to_owner < length($data)) {
1003 23         98 my $owner = Parse::Win32Registry::SID->new(substr($data,
1004             $offset_to_owner));
1005 23 100       71 return if !defined $owner;
1006 21         52 $self->{_owner} = $owner;
1007 21 50       121 if ($offset_to_owner + $owner->get_length > $sd_len) {
1008 21         44 $sd_len = $offset_to_owner + $owner->get_length;
1009             }
1010             }
1011 33 100 66     135 if ($offset_to_group > 0 && $offset_to_group < length($data)) {
1012 21         61 my $group = Parse::Win32Registry::SID->new(substr($data,
1013             $offset_to_group));
1014 21 100       66 return if !defined $group;
1015 19         48 $self->{_group} = $group;
1016 19 50       46 if ($offset_to_group + $group->get_length > $sd_len) {
1017 19         42 $sd_len = $offset_to_group + $group->get_length;
1018             }
1019             }
1020 31 100 66     98 if ($offset_to_sacl > 0 && $offset_to_sacl < length($data)) {
1021 12         44 my $sacl = Parse::Win32Registry::ACL->new(substr($data,
1022             $offset_to_sacl));
1023 12 100       42 return if !defined $sacl;
1024 10         23 $self->{_sacl} = $sacl;
1025 10 100       25 if ($offset_to_sacl + $sacl->get_length > $sd_len) {
1026 3         9 $sd_len = $offset_to_sacl + $sacl->get_length;
1027             }
1028             }
1029 29 100 66     109 if ($offset_to_dacl > 0 && $offset_to_dacl < length($data)) {
1030 17         68 my $dacl = Parse::Win32Registry::ACL->new(substr($data,
1031             $offset_to_dacl));
1032 17 100       82 return if !defined $dacl;
1033 14         32 $self->{_dacl} = $dacl;
1034 14 100       35 if ($offset_to_dacl + $dacl->get_length > $sd_len) {
1035 3         9 $sd_len = $offset_to_dacl + $dacl->get_length;
1036             }
1037             }
1038 26         48 $self->{_length} = $sd_len;
1039 26         49 bless $self, $class;
1040              
1041 26         75 return $self;
1042             }
1043              
1044             sub get_owner {
1045 25     25   11744 my $self = shift;
1046              
1047 25         113 return $self->{_owner};
1048             }
1049              
1050             sub get_group {
1051 25     25   10783 my $self = shift;
1052              
1053 25         109 return $self->{_group};
1054             }
1055              
1056             sub get_sacl {
1057 25     25   10558 my $self = shift;
1058              
1059 25         117 return $self->{_sacl};
1060             }
1061              
1062             sub get_dacl {
1063 25     25   9230 my $self = shift;
1064              
1065 25         109 return $self->{_dacl};
1066             }
1067              
1068             sub as_string {
1069 0     0   0 croak 'Usage: Security Descriptors do not have an as_string method; use as_stanza instead';
1070             }
1071              
1072             sub as_stanza {
1073 0     0   0 my $self = shift;
1074              
1075 0         0 my $stanza = '';
1076 0 0       0 if (defined(my $owner = $self->{_owner})) {
1077 0         0 $stanza .= 'Owner SID: ' . $owner->as_string;
1078 0         0 my $name = $owner->get_name;
1079 0 0       0 $stanza .= " [$name]" if defined $name;
1080 0         0 $stanza .= "\n";
1081             }
1082 0 0       0 if (defined(my $group = $self->{_group})) {
1083 0         0 $stanza .= 'Group SID: ' . $group->as_string;
1084 0         0 my $name = $group->get_name;
1085 0 0       0 $stanza .= " [$name]" if defined $name;
1086 0         0 $stanza .= "\n";
1087             }
1088 0 0       0 if (defined(my $sacl = $self->{_sacl})) {
1089 0         0 foreach my $ace ($sacl->get_list_of_aces) {
1090 0         0 $stanza .= 'SACL ACE: ' . $ace->as_string . "\n";
1091             }
1092             }
1093 0 0       0 if (defined(my $dacl = $self->{_dacl})) {
1094 0         0 foreach my $ace ($dacl->get_list_of_aces) {
1095 0         0 $stanza .= 'DACL ACE: ' . $ace->as_string . "\n";
1096             }
1097             }
1098 0         0 return $stanza;
1099             }
1100              
1101             sub get_length {
1102 9     9   13 my $self = shift;
1103              
1104 9         39 return $self->{_length};
1105             }
1106              
1107             1;