File Coverage

blib/lib/Parse/Lnk.pm
Criterion Covered Total %
statement 293 321 91.2
branch 62 82 75.6
condition 10 15 66.6
subroutine 20 20 100.0
pod 5 5 100.0
total 390 443 88.0


line stmt bran cond sub pod time code
1             package Parse::Lnk;
2            
3             # Many sections of this code were adapted from:
4             # Windows LNK file parser - Jacob Cunningham - jakec76@users.sourceforge.net
5             # from the SourceForge project located at:
6             # https://sourceforge.net/projects/jafat/files/lnk-parse/lnk-parse-1.0/lnk-parse-1.0.tar.gz
7             # Based on the contents of the document:
8             # http://www.i2s-lab.com/Papers/The_Windows_Shortcut_File_Format.pdf
9            
10 2     2   146086 use 5.006;
  2         16  
11 2     2   11 use strict;
  2         4  
  2         43  
12 2     2   21 use warnings;
  2         4  
  2         81  
13 2     2   21 use Carp qw(croak);
  2         3  
  2         6083  
14            
15             our $VERSION = '0.04';
16            
17             =pod
18            
19             =encoding latin1
20            
21             =head1 NAME
22            
23             Parse::Lnk - A cross-platform, depencency free, Windows shortcut (.lnk) meta data parser.
24            
25             =head1 VERSION
26            
27             Version 0.04
28            
29             =cut
30            
31             require Exporter;
32             our @ISA = qw(Exporter);
33             our @EXPORT_OK = qw(parse_lnk resolve_lnk);
34            
35             our $map = { # Tag names made up based on the docs
36             flag => {
37             0 => {
38             0 => 'NO SHELLIDLIST',
39             1 => 'HAS SHELLIDLIST',
40             },
41             1 => {
42             0 => 'NOT POINT TO FILE/DIR',
43             1 => 'POINTS TO FILE/DIR',
44             },
45             2 => {
46             0 => 'NO DESCRIPTION',
47             1 => 'HAS DESCRIPTION',
48             },
49             3 => {
50             0 => 'NO RELATIVE PATH STRING',
51             1 => 'HAS RELATIVE PATH STRING',
52             },
53             4 => {
54             0 => 'NO WORKING DIRECTORY',
55             1 => 'HAS WORKING DIRECTORY',
56             },
57             5 => {
58             0 => 'NO CMD LINE ARGS',
59             1 => 'HAS CMD LINE ARGS',
60             },
61             6 => {
62             0 => 'NO CUSTOM ICON',
63             1 => 'HAS CUSTOM ICON',
64             },
65             },
66             file => {
67             0 => 'READ ONLY TARGET',
68             1 => 'HIDDEN TARGET',
69             2 => 'SYSTEM FILE TARGET',
70             3 => 'VOLUME LABEL TARGET (not possible)',
71             4 => 'DIRECTORY TARGET',
72             5 => 'ARCHIVE',
73             6 => 'NTFS EFS',
74             7 => 'NORMAL TARGET',
75             8 => 'TEMP. TARGET',
76             9 => 'SPARSE TARGET',
77             10 => 'REPARSE POINT DATA TARGET',
78             11 => 'COMPRESSED TARGET',
79             12 => 'TARGET OFFLINE',
80             },
81             show_wnd => {
82             0 => 'SW_HIDE',
83             1 => 'SW_NORMAL',
84             2 => 'SW_SHOWMINIMIZED',
85             3 => 'SW_SHOWMAXIMIZED',
86             4 => 'SW_SHOWNOACTIVE',
87             5 => 'SW_SHOW',
88             6 => 'SW_MINIMIZE',
89             7 => 'SW_SHOWMINNOACTIVE',
90             8 => 'SW_SHOWNA',
91             9 => 'SW_RESTORE',
92             10 => 'SW_SHOWDEFAULT',
93             },
94             vol_type => {
95             0 => 'Unknown',
96             1 => 'No root directory',
97             2 => 'Removable (Floppy, Zip, USB, etc.)',
98             3 => 'Fixed (Hard Disk)',
99             4 => 'Remote (Network Drive)',
100             5 => 'CD-ROM',
101             6 => 'RAM Drive',
102             },
103             };
104            
105             sub resolve_lnk {
106 10     10 1 9359 my $filename = shift;
107 10         47 my $l = __PACKAGE__->new (
108             filename => $filename,
109             resolve => 1,
110             );
111 10         37 $l->_parse;
112 10         81 $l->{base_path};
113             }
114            
115             sub parse_lnk {
116 10     10 1 9341 my $filename = shift;
117 10         88 my $l = __PACKAGE__->new (
118             filename => $filename,
119             );
120 10         36 $l->_parse;
121 10 100       51 return if $l->{error};
122 5         26 $l;
123             }
124            
125             sub new {
126 40     40 1 6529 my $class = shift;
127 40 50 33     257 if (@_ and @_ % 2) {
128 0         0 croak "This method expects (name => value) arguments. Odd number of arguments received";
129             }
130 40         137 my $self = {
131             @_,
132             };
133 40         117 bless $self, $class;
134             }
135            
136             sub from {
137 10     10 1 16987 my $self = shift;
138 10         22 my $filename = shift;
139 10 50       51 $self = $self->new (
140             filename => $filename,
141             ) unless ref $self;
142 10         44 $self->_parse;
143 10 100       55 return if $self->{error};
144 5         27 $self;
145             }
146            
147             sub parse {
148 10     10 1 50 my $self = shift;
149 10         17 my $filename = shift;
150 10 50       37 $self = $self->new (
151             filename => $filename,
152             ) unless ref $self;
153 10         31 $self->_parse;
154 10 100       50 return if $self->{error};
155 5         28 $self;
156             }
157            
158             sub _reset {
159 40     40   71 my $self = shift;
160 40 50       96 return unless ref $self;
161 40         153 for my $k (keys %$self) {
162 50         134 delete $self->{$k};
163             }
164 40         71 $self;
165             }
166            
167             sub _parse {
168 40     40   74 my $self = shift;
169 40         84 my $filename = $self->{filename};
170 40         83 my $resolve = $self->{resolve};
171 40         125 $self->_reset;
172 40 50       111 if (not defined $filename) {
173 0         0 $self->{error} = 'A filename is required';
174 0         0 return;
175             }
176 40 100       1390 if (not -f $filename) {
177 8         29 $self->{error} = "Not a file";
178 8         19 return;
179             }
180 32 50       1877 if (open my $in, '<', $filename) {
181 32         166 binmode $in;
182 32         108 $self->{_fh} = $in;
183             } else {
184             # We set error before croak, in case this call is being eval'ed
185 0         0 $self->{error} = "Can't open file '$filename' for reading";
186 0         0 croak $self->{error};
187             }
188            
189 32         128 my $header = $self->_read_unpack(0, 1);
190 32 100       121 if ($header ne '4c') {
191 12         27 $self->{error} = 'Invalid Lnk file header';
192 12         134 close $self->{_fh};
193 12         34 delete $self->{_fh};
194 12         47 return;
195             }
196            
197 20         69 $self->{guid} = $self->_read_unpack(4, 16);
198            
199 20         76 my $flags = $self->_read_unpack_bin(20, 1);
200 20         94 my $flag_cnt = 0;
201 20         78 my @flag_bits = (0, 0, 0, 0, 0, 0, 0, 0);
202 20         83 while ($flag_cnt < 7) {
203 140         212 my $flag_bit = substr $flags, $flag_cnt, 1;
204 140         159 push @{$self->{flags}}, $map->{flag}->{$flag_cnt}->{$flag_bit};
  140         494  
205 140 100       287 if ($flag_bit eq '1') {
206 40 50 33     181 if ($flag_cnt >= 0 and $flag_cnt <= 6) {
207 40         63 $flag_bits[$flag_cnt] = 1;
208             }
209             }
210 140         279 $flag_cnt++;
211             }
212            
213             # File Attributes 4bytes@18h = 24d
214             # Only a non-zero if "Flag bit 1" above is set to 1
215             #
216 20 50       217 if ($flag_bits[1] == 1) {
217 20         58 my $file_attrib = $self->_read_unpack_bin(24, 2);
218 20         48 my $file_att_cnt = 0;
219 20         70 while ($file_att_cnt < 13) {
220 260         352 my $file_bit = substr $file_attrib, $file_att_cnt, 1;
221 260 100       408 push @{$self->{attributes}}, $map->{file}->{$file_att_cnt} if $file_bit;
  28         124  
222 260         433 $file_att_cnt++;
223             }
224             }
225            
226             # Create time 8bytes @ 1ch = 28
227 20         64 my $ctime = $self->_read_unpack(28, 8);
228 20         69 $ctime = Parse::Windows::Shortcut::Bigint::bighex($self->_reverse_hex($ctime));
229 20         876 $ctime = $self->_MStime_to_unix($ctime);
230 20         58 $self->{create_time} = $ctime;
231            
232             # Access time 8 bytes@ 0x24 = 36D
233 20         57 my $atime = $self->_read_unpack(36, 8);
234 20         68 $atime = Parse::Windows::Shortcut::Bigint::bighex($self->_reverse_hex($atime));
235 20         585 $atime = $self->_MStime_to_unix($atime);
236 20         65 $self->{last_accessed_time} = $atime;
237            
238             # Mod Time8b @ 0x2C = 44D
239 20         52 my $mtime = $self->_read_unpack(44, 8);
240 20         63 $mtime = Parse::Windows::Shortcut::Bigint::bighex($self->_reverse_hex($mtime));
241 20         551 $mtime = $self->_MStime_to_unix($mtime);
242 20         61 $self->{modified_time} = $mtime;
243            
244             # Target File length starts @ 34h = 52d
245 20         57 my $f_len = $self->_read_unpack(52, 4);
246 20         67 $f_len = hex $self->_reverse_hex($f_len);
247 20         96 $self->{target_length} = $f_len;
248            
249             # Icon File info starts @ 38h = 56d
250 20         66 my $ico_num = $self->_read_unpack(56, 4);
251 20         41 $ico_num = hex $ico_num;
252 20         56 $self->{icon_index} = $ico_num;
253            
254             # ShowWnd val to pass to target
255             # Starts @3Ch = 60d
256 20         53 my $show_wnd = $self->_read_unpack(60, 1);
257 20         41 $show_wnd = hex $show_wnd;
258 20         49 $self->{show_wnd} = $show_wnd;
259 20         95 $self->{show_wnd_flag} = $map->{show_wnd}->{$show_wnd};
260            
261             # Hot key
262             # Starts @40h = 64d
263 20         52 my $hot_key = $self->_read_unpack(64, 4);
264 20         39 $hot_key = hex $hot_key;
265 20         59 $self->{hot_key} = $hot_key;
266            
267             # ItemID List
268             # Read size of item ID list
269 20         55 my $i_len = $self->_read_unpack(76, 2);
270 20         48 $i_len = hex $self->_reverse_hex($i_len);
271             # skip to end of list
272 20         42 my $end_of_list = (78 + $i_len);
273            
274             # FileInfo structure
275             #
276 20         37 my $struc_start = $end_of_list;
277 20         28 my $first_off_off = ($struc_start + 4);
278 20         25 my $vol_flags_off = ($struc_start + 8);
279 20         26 my $local_vol_off = ($struc_start + 12);
280 20         104 my $base_path_off = ($struc_start + 16);
281 20         25 my $net_vol_off = ($struc_start + 20);
282 20         39 my $rem_path_off = ($struc_start + 24);
283            
284             # Structure length
285 20         40 my $struc_len = $self->_read_unpack($struc_start, 4);
286 20         71 $struc_len = hex $self->_reverse_hex($struc_len);
287 20         41 my $struc_end = $struc_start + $struc_len;
288            
289             # First offset after struct - Should be 1C under normal circumstances
290 20         68 my $first_off = $self->_read_unpack($first_off_off, 1);
291            
292             # File location flags
293 20         88 my $vol_flags = $self->_read_unpack_bin($vol_flags_off, 1);
294 20         157 $vol_flags = substr $vol_flags, 0, 2;
295 20         56 my @vol_bits = (0, 0);
296 20 100       105 if ($vol_flags =~ /10/) {
297 8         21 $self->{target_type} = 'local';
298 8         37 $vol_bits[0] = 1;
299 8         19 $vol_bits[1] = 0;
300             }
301             # Haven't found this case yet...
302 20 100       83 if ($vol_flags =~ /01/) {
303 4         15 $self->{target_type} = 'network';
304 4         11 $vol_bits[0] = 0;
305 4         9 $vol_bits[1] = 1;
306             }
307             # But this one I did:
308 20 100       88 if ($vol_flags =~ /11/) {
309 8         28 $self->{target_type} = 'network';
310 8         12 $vol_bits[0] = 1;
311 8         21 $vol_bits[1] = 1;
312             }
313            
314             # Local volume table
315             # Random garbage if bit0 is clear in volume flags
316 20 100 100     108 if ($vol_bits[0] == 1 and $vol_bits[1] == 0) {
317             # This is the offset of the local volume table within the
318             #File Info Location Structure
319 8         21 my $loc_vol_tab_off = $self->_read_unpack($local_vol_off, 4);
320 8         20 $loc_vol_tab_off = hex $self->_reverse_hex($loc_vol_tab_off);
321            
322             # This is the asolute start location of the local volume table
323 8         17 my $loc_vol_tab_start = $loc_vol_tab_off + $struc_start;
324            
325             # This is the length of the local volume table
326 8         22 my $local_vol_len = $self->_read_unpack(($loc_vol_tab_off + $struc_start), 4);
327 8         21 $local_vol_len = hex $self->_reverse_hex($local_vol_len);
328            
329             # We now have enough info to
330             # Calculate the end of the local volume table.
331 8         14 my $local_vol_tab_end = $loc_vol_tab_start + $local_vol_len;
332            
333             # This is the volume type
334 8         18 my $curr_tab_offset = $loc_vol_tab_off + $struc_start + 4;
335 8         21 my $vol_type = $self->_read_unpack($curr_tab_offset, 4);
336 8         24 $vol_type = hex $self->_reverse_hex($vol_type);
337 8         35 $self->{volume_type} = $map->{vol_type}->{$vol_type};
338            
339             # Volume Serial Number
340 8         19 $curr_tab_offset = $loc_vol_tab_off + $struc_start + 8;
341 8         20 my $vol_serial = $self->_read_unpack($curr_tab_offset, 4);
342 8         21 $vol_serial = $self->_reverse_hex($vol_serial);
343 8         19 $self->{volume_serial} = $vol_serial;
344            
345             # Get the location, and length of the volume label
346             # we should really read the vol_label_loc from offset Ch
347 8         16 my $vol_label_loc = $loc_vol_tab_off + $struc_start + 16;
348 8         24 my $vol_label_len = $local_vol_tab_end - $vol_label_loc;
349 8         27 my $vol_label = $self->_read_unpack_ascii($vol_label_loc, $vol_label_len);
350 8         36 $self->{volume_label} = $vol_label;
351            
352             # This is the offset of the base path info within the
353             # File Info structure
354             # Random Garbage when bit0 is clear in volume flags
355 8         27 my $base_path_off = $self->_read_unpack($base_path_off, 4);
356 8         24 $base_path_off = hex $self->_reverse_hex($base_path_off);
357 8         14 $base_path_off = $struc_start + $base_path_off;
358            
359             # Read base path data upto NULL term
360 8         23 my $bp_data = $self->_read_null_term($base_path_off);
361 8         19 $self->{base_path} = $bp_data;
362 8 100       31 if ($resolve) {
363 2         46 close $self->{_fh};
364 2         7 delete $self->{_fh};
365 2         17 return $self;
366             }
367             }
368            
369             # Network Volume Table
370 18 100 66     79 if ($vol_bits[0] == 0 and $vol_bits[1] == 1) {
371 4         14 $net_vol_off = hex $self->_reverse_hex($self->_read_unpack($net_vol_off, 4));
372 4         9 $net_vol_off = $struc_start + $net_vol_off;
373 4         11 my $net_vol_len = $self->_read_unpack($net_vol_off, 4);
374 4         12 $net_vol_len = hex $self->_reverse_hex($net_vol_len);
375            
376             # Network Share Name
377 4         9 my $net_share_name_off = $net_vol_off + 8;
378 4         11 my $net_share_name_loc = hex $self->_reverse_hex($self->_read_unpack($net_share_name_off, 4));
379 4 50       15 if ($net_share_name_loc ne "20") {
380 0         0 close delete $self->{_fh};
381 0         0 $self->{error} = 'Error: NSN ofset should always be 14h';
382 0         0 close $self->{_fh};
383 0         0 delete $self->{_fh};
384 0         0 return $self;
385             }
386 4         13 $net_share_name_loc = $net_vol_off + $net_share_name_loc;
387 4         13 my $net_share_name = $self->_read_null_term($net_share_name_loc);
388 4         12 $self->{base_path} = $net_share_name;
389 4 100       12 if ($resolve) {
390 1         24 close $self->{_fh};
391 1         5 delete $self->{_fh};
392 1         8 return $self;
393             }
394            
395             # Mapped Network Drive Info
396 3         9 my $net_share_mdrive = $net_vol_off + 12;
397 3         10 $net_share_mdrive = $self->_read_unpack($net_share_mdrive, 4);
398 3         11 $net_share_mdrive = hex $self->_reverse_hex($net_share_mdrive);
399 3 50       10 if ($net_share_mdrive ne "0") {
400 3         6 $net_share_mdrive = $net_vol_off + $net_share_mdrive;
401 3         8 $net_share_mdrive = $self->_read_null_term($net_share_mdrive);
402 3         9 $self->{mapped_drive} = $net_share_mdrive;
403             }
404             }
405            
406 17 100 100     97 if ($vol_bits[0] == 1 and $vol_bits[1] == 1) {
407             # Finding the location, as I'm not sure this is always 104
408 8         28 for my $i (1..10000) {
409 208         282 my $n = 4 * $i;
410 208         355 my $l = $self->_read_unpack($n, 4);
411 208         446 $l = hex $self->_reverse_hex($l);
412 208         304 my $net_share_name_off = $n + 8;
413 208         367 my $net_share_name_loc = hex $self->_reverse_hex($self->_read_unpack($net_share_name_off, 4));
414 208 100       466 if ($net_share_name_loc ne "20") {
415 200         355 next;
416             }
417 8         26 $net_vol_off = $n;
418 8         21 last;
419             }
420            
421 8         22 my $net_vol_len = $self->_read_unpack($net_vol_off, 4);
422 8         26 $net_vol_len = hex $self->_reverse_hex($net_vol_len);
423            
424             # Network Share Name
425 8         18 my $net_share_name_off = $net_vol_off + 8;
426 8         26 my $net_share_name_loc = hex $self->_reverse_hex($self->_read_unpack($net_share_name_off, 4));
427 8 50       36 if ($net_share_name_loc ne "20") {
428 0         0 close delete $self->{_fh};
429 0         0 $self->{error} = 'Error: NSN ofset should always be 14h';
430 0         0 close $self->{_fh};
431 0         0 delete $self->{_fh};
432 0         0 return $self;
433             }
434 8         21 $net_share_name_loc = $net_vol_off + $net_share_name_loc;
435 8         28 my $net_share_name = $self->_read_null_term($net_share_name_loc);
436 8         41 $self->{base_path} = $net_share_name;
437 8 100       24 if ($resolve) {
438 2         56 close $self->{_fh};
439 2         12 delete $self->{_fh};
440 2         29 return $self;
441             }
442            
443             # Mapped Network Drive Info
444 6         12 my $net_share_mdrive = $net_vol_off + 12;
445 6         14 $net_share_mdrive = $self->_read_unpack($net_share_mdrive, 4);
446 6         17 $net_share_mdrive = hex $self->_reverse_hex($net_share_mdrive);
447 6 50       23 if ($net_share_mdrive ne "0") {
448 0         0 $net_share_mdrive = $net_vol_off + $net_share_mdrive;
449 0         0 $net_share_mdrive = $self->_read_null_term($net_share_mdrive);
450 0         0 $self->{mapped_drive} = $net_share_mdrive;
451             }
452             }
453            
454             #Remaining Path
455 15         43 $rem_path_off = $self->_read_unpack($rem_path_off, 4);
456 15         37 $rem_path_off = hex $self->_reverse_hex($rem_path_off);
457 15         33 $rem_path_off = $struc_start + $rem_path_off;
458 15         36 my $rem_data = $self->_read_null_term($rem_path_off);
459 15         46 $self->{remaining_path} = $rem_data;
460            
461             # The next starting location is the end of the structure
462 15         22 my $next_loc = $struc_end;
463 15         25 my $addnl_text;
464            
465             # Description String
466             # present if bit2 is set in header flags.
467 15 50       74 if ($flag_bits[2] eq "1") {
468 0         0 ($addnl_text, $next_loc) = $self->_add_info($next_loc);
469 0         0 $self->{description} = $addnl_text;
470 0         0 $next_loc = $next_loc + 1;
471             }
472            
473             # Relative Path
474 15 50       60 if ($flag_bits[3] eq "1") {
475 0         0 ($addnl_text, $next_loc) = $self->_add_info($next_loc);
476 0         0 $self->{relative_path} = $addnl_text;
477 0         0 $next_loc = $next_loc + 1;
478             }
479             # Working Dir
480 15 100       47 if ($flag_bits[4] eq "1") {
481 6         20 ($addnl_text, $next_loc) = $self->_add_info($next_loc);
482 6         48 ($self->{working_directory} = $addnl_text) =~ s/\x00//g;
483 6         16 $next_loc = $next_loc + 1;
484             }
485             # CMD Line
486 15 50       47 if ($flag_bits[5] eq "1") {
487 0         0 ($addnl_text, $next_loc) = $self->_add_info($next_loc);
488 0         0 $self->{command_line} = $addnl_text;
489 0         0 $next_loc = $next_loc + 1;
490             }
491             #Icon filename
492 15         48 ($addnl_text, $next_loc) = $self->_add_info($next_loc);
493 15 50       65 if ($flag_bits[6] eq "1") {
494 0         0 $self->{icon_filename} = $addnl_text;
495             }
496 15         397 close delete $self->{_fh};
497 15         159 $self;
498             }
499            
500             sub _add_info {
501 21     21   36 my $self = shift;
502 21         46 my ($tmp_start_loc) = shift;
503 21         57 my $tmp_len = 2 * hex $self->_reverse_hex($self->_read_unpack($tmp_start_loc, 1));
504 21         42 $tmp_start_loc++;
505 21 100       59 if ($tmp_len ne "0") {
506 15         38 my $tmp_string = $self->_read_unpack_ascii($tmp_start_loc, $tmp_len);
507 15         33 my $now_loc = tell;
508 15         46 return ($tmp_string, $now_loc);
509             } else {
510 6         13 my $now_loc = tell;
511 6         12 my $tmp_string = 'Null';
512 6         28 return ($tmp_string, $now_loc);
513             }
514             }
515            
516             sub _read_unpack {
517 781     781   1150 my $self = shift;
518 781         1214 my ($loc, $bites) = @_;
519 781         978 my $tmp_data;
520 781 50       8692 seek ($self->{_fh}, $loc, 0) or croak "Can't seek to $loc";
521 781         7099 read $self->{_fh}, $tmp_data, $bites;
522 781         2752 $tmp_data = unpack 'H*', $tmp_data;
523 781         2159 return $tmp_data;
524             }
525            
526             sub _read_unpack_ascii {
527 23     23   36 my $self = shift;
528 23         44 my ($loc, $bites) = @_;
529 23         37 my $tmp_data;
530 23 50       257 seek ($self->{_fh}, $loc, 0) or croak "Can't seek to $loc\n";
531 23         230 read $self->{_fh}, $tmp_data, $bites;
532 23         105 $tmp_data = unpack 'A*', $tmp_data;
533 23         71 return $tmp_data;
534             }
535            
536             sub _read_unpack_bin {
537 60     60   99 my $self = shift;
538 60         129 my ($loc, $bites) = @_;
539 60         86 my $tmp_data;
540 60 50       703 seek ($self->{_fh}, $loc, 0) or croak "Can't seek to $loc\n";
541 60         505 read $self->{_fh}, $tmp_data, $bites;
542 60         237 $tmp_data = unpack 'b*', $tmp_data;
543 60         170 return $tmp_data;
544             }
545            
546             sub _MStime_to_unix {
547 60     60   112 my $self = shift;
548 60         90 my $mstime_dec = shift;
549             # The number of seconds between Unix/FILETIME epochs
550 60         74 my $MSConversion = '11644473600';
551             # Convert 100ms increments to Seconds.
552 60         211 $mstime_dec *= .0000001;
553             # Add difference in epochs
554 60         114 $mstime_dec -= $MSConversion;
555 60         682 sprintf '%0.3f', $mstime_dec;
556             }
557            
558             sub _reverse_hex {
559 649     649   1028 my $self = shift;
560 649         801 my $HEXDATE = shift;
561 649         810 my @bytearry;
562 649         870 my $byte_cnt = 0;
563 649 100       1501 my $max_byte_cnt = length($HEXDATE) < 16 ? int(length($HEXDATE) / 2) : 8;
564 649         741 my $byte_offset = 0;
565 649         1182 while ($byte_cnt < $max_byte_cnt) {
566 2727         3940 my $tmp_str = substr $HEXDATE, $byte_offset, 2;
567 2727         3751 push @bytearry, $tmp_str;
568 2727         3057 $byte_cnt++;
569 2727         4336 $byte_offset += 2;
570             }
571 649         2021 return join '', reverse @bytearry;
572             }
573            
574             sub _read_null_term {
575 38     38   54 my $self = shift;
576 38         51 my $loc = shift;
577             # Save old record seperator
578 38         99 my $old_rs = $/;
579             # Set new seperator to NULL term.
580 38         116 $/ = "\0";
581 38 50       438 seek ($self->{_fh}, $loc, 0) or die "Can't seek to $loc\n";
582 38         114 my $fh = $self->{_fh};
583 38         387 my $term_data = <$fh>;
584 38 100       158 chomp $term_data if $term_data;
585             # Reset
586 38         115 $/ = $old_rs;
587 38         95 return $term_data;
588             }
589            
590             {
591             package Parse::Windows::Shortcut::Bigint;
592 2     2   1500 use bigint qw(hex);
  2         11698  
  2         10  
593            
594             sub bighex {
595 60     60   103 my $v = shift;
596 60         1895 my $h = hex $v;
597 60         17252 $h.'';
598             }
599             }
600            
601            
602             =head1 SYNOPSIS
603            
604             This module reads Win32 shortcuts (*.lnk files) to obtain the meta data in them.
605            
606             Its goal is to be able to resolve the path they point to (along with other data),
607             from any platform/OS, without the need for depencencies.
608            
609             Its use is very simple:
610            
611             use Parse::Lnk;
612            
613             my $data = Parse::Lnk->from($filename);
614            
615             # $data is now a hashref if the file was parsed successfully.
616             # undef if not.
617            
618             ##########
619             # Or ... #
620             ##########
621            
622             use Parse::Lnk qw(parse_lnk);
623            
624             my $data = parse_lnk $filename;
625            
626             # $data is now a hashref if the file was parsed successfully.
627             # undef if not.
628            
629             ##########
630             # Or ... #
631             ##########
632            
633             use Parse::Lnk qw(resolve_lnk);
634            
635             my $path = resolve_lnk $filename;
636            
637             # $path is now a string with the path the lnk file points to.
638             # undef if the lnk file was not parsed successfully.
639            
640             ###############################################################
641             # Or, if you want a little more information/control on errors #
642             ###############################################################
643            
644             use Parse::Lnk;
645            
646             my $lnk = Parse::Lnk->new;
647            
648             $lnk->parse($filename) or die $lnk->{error};
649            
650             # Or:
651            
652             $lnk->parse($filename);
653            
654             if ($lnk->{error}) {
655             # ... do your own error handling;
656             }
657            
658            
659            
660            
661             =head1 EXPORT
662            
663             Nothing is exported by default. You can explicitly import this functions:
664            
665             =head2 parse_lnk($filename)
666            
667             This will return a Parse::Lnk instance, which is a hashref. The keys in that
668             hashref depend on the data that was parsed from the .lnk file.
669            
670             It will return C on error.
671            
672             use Parse::Lnk qw(parse_lnk);
673            
674             my $lnk = parse_lnk $filename;
675            
676             if ($lnk) {
677             print "$filename points to path $lnk->{base_path}\n";
678            
679             my $create_date = localtime $lnk->{create_time};
680             print "$filename was created on $create_date";
681             } else {
682             print "Could not parse $filename";
683             }
684            
685             =head2 resolve_lnk($filename)
686            
687             This will return the path the .lnk file is pointing to.
688            
689             It will return C on error.
690            
691             use Parse::Lnk qw(resolve_lnk);
692            
693             my $path = resolve_lnk $filename;
694            
695             if ($path) {
696             print "$filename points to path $path";
697             } else {
698             print "Could not parse $filename";
699             }
700            
701            
702             =head1 METHODS
703            
704             You can create a C instance and call a few methods on it. This
705             may give you more control/information when something goes wrong while parsing
706             the file.
707            
708             =head2 new
709            
710             This creates a new instance. You can pass the C value as argument,
711             or you can set/change it later.
712            
713             use Parse::Lnk;
714            
715             my $lnk = Parse::Lnk->new(filename => $filename);
716            
717             # or
718            
719             my $lnk = Parse::Lnk->new;
720             $lnk->{filename} = $filename;
721            
722             =head2 parse
723            
724             This method will parse the current C in the instance. You can change
725             the value of C and parse again at any point.
726            
727             use Parse::Lnk;
728            
729             my $lnk = Parse::Lnk->new(filename => $filename);
730            
731             $lnk->parse;
732            
733             if ($lnk->{error}) {
734             # handle the error
735             } else {
736             print "$filename points to $lnk->{base_path}";
737             }
738            
739             for my $other_filename (@filenames) {
740             $lnk->{filename} = $other_filename;
741             $lnk->parse;
742            
743             if ($lnk->{error}) {
744             # handle the error
745             next;
746             }
747            
748             print "$other_filename points to $lnk->{base_path}";
749             }
750            
751             =head2 from
752            
753             It will return a C instance, or undef on error. This method was
754             written with plain package name calling in mind:
755            
756             use Parse::Lnk;
757            
758             my $lnk = Parse::Lnk->from($filename);
759            
760             if ($lnk) {
761             print "$filename points to path $lnk->{base_path}\n";
762            
763             my $create_date = localtime $lnk->{create_time};
764             print "$filename was created on $create_date";
765             } else {
766             print "Could not parse $filename";
767             }
768            
769            
770             =head1 AUTHOR
771            
772             Francisco Zarabozo, C<< >>
773            
774             =head1 BUGS
775            
776             I'm sure there are many. I haven't found bugs with the lnk files I've tested
777             it. If you find a bug or you have a problem reading a shortcut/lnk file,
778             please don't hesitate to report it and don't forget to include the file in
779             question. If you are on Windows, you will have to zip the file in a way that
780             is the lnk file the one being zipped and not the actual directory/file it
781             is pointing to. I promise to look at any report and work on a solution as
782             fast as I can.
783            
784             Please report any bugs or feature requests to C, or through
785             the web interface at L. I will be notified, and then you'll
786             automatically be notified of progress on your bug as I make changes.
787            
788            
789             =head1 SUPPORT
790            
791             You can find documentation for this module with the perldoc command.
792            
793             perldoc Parse::Lnk
794            
795            
796             You can also look for information at:
797            
798             =over 4
799            
800             =item * RT: CPAN's request tracker (report bugs here)
801            
802             L
803            
804             =item * AnnoCPAN: Annotated CPAN documentation
805            
806             L
807            
808             =item * CPAN Ratings
809            
810             L
811            
812             =item * Search CPAN
813            
814             L
815            
816             =back
817            
818            
819             =head1 ACKNOWLEDGEMENTS
820            
821            
822             =head1 LICENSE AND COPYRIGHT
823            
824             This software is copyright (c) 2021 by Francisco Zarabozo.
825            
826             This is free software; you can redistribute it and/or modify it under
827             the same terms as the Perl 5 programming language system itself.
828            
829            
830             =cut
831            
832             1;