File Coverage

blib/lib/D64/Disk/Dir/Entry.pm
Criterion Covered Total %
statement 144 164 87.8
branch 25 38 65.7
condition 6 12 50.0
subroutine 25 27 92.5
pod 17 17 100.0
total 217 258 84.1


line stmt bran cond sub pod time code
1             package D64::Disk::Dir::Entry;
2              
3             =head1 NAME
4              
5             D64::Disk::Dir::Entry - Handling individual Commodore (D64/D71/D81) disk image directory entries
6              
7             =head1 SYNOPSIS
8              
9             use D64::Disk::Dir::Entry;
10              
11             # Create a new directory entry and initialize it with 30 bytes of binary data retrieved from a D64 disk image:
12             my $entryObj = D64::Disk::Dir::Entry->new($bytes);
13              
14             # Get filename converted to ASCII string:
15             my $convert2ascii = 1;
16             my $name = $entryObj->get_name($convert2ascii);
17              
18             # Get various parameters describing detailed entry properties:
19             my $type = $entryObj->get_type();
20             my $track = $entryObj->get_track();
21             my $sector = $entryObj->get_sector();
22              
23             # Print out a single line out of entire disk directory with the contents of this particular entry to the standard output:
24             $entryObj->print_entry();
25              
26             =head1 DESCRIPTION
27              
28             This package provides a helper class for D64::Disk::Dir module, enabling user to handle individual directory entries in a higher-level object-oriented way.
29              
30             =head1 METHODS
31              
32             =cut
33              
34 4     4   27 use bytes;
  4         13  
  4         38  
35 4     4   121 use strict;
  4         9  
  4         71  
36 4     4   17 use warnings;
  4         8  
  4         177  
37              
38             our $VERSION = '0.05';
39              
40 4     4   21 use Carp qw/carp croak verbose/;
  4         7  
  4         378  
41 4     4   27 use Data::Dumper;
  4         7  
  4         218  
42              
43 4     4   1810 use D64::Disk::Image qw(:all);
  4         14772  
  4         1083  
44 4     4   29 use D64::Disk::Dir;
  4         8  
  4         7135  
45              
46             # File type names:
47             our @file_types = qw/del seq prg usr rel cbm dir ???/;
48              
49             =head2 new
50              
51             Create new C object and initialize it with 30 bytes of binary data describing each directory entry on a D64 disk image (or a physical disk):
52              
53             my $entryObj = D64::Disk::Dir::Entry->new($bytes);
54              
55             The reason for initializing object not with 32 bytes of physical data but with 30 bytes instead is that two first bytes of each entry in a directory sector always should be $00 $00 as they are unused (except for the very first entry, in which case those bytes are still directory-wide, not entry-specific).
56              
57             A valid C object is returned upon success, an undefined value otherwise.
58              
59             =cut
60              
61             sub new {
62 103     103 1 172 my $this = shift;
63 103   33     300 my $class = ref($this) || $this;
64 103         148 my $self = {};
65 103         176 bless $self, $class;
66 103         213 my $initOK = $self->_initialize(@_);
67 103 50       225 if ($initOK) {
68 103         240 return $self;
69             }
70             else {
71 0         0 return undef;
72             }
73             }
74              
75             sub _initialize {
76 103     103   143 my $self = shift;
77 103         137 my $bytes = shift;
78             # Verify valid bytes sequence:
79 103 50       205 unless (length $bytes == 30) {
80 0         0 carp 'Initializing D64::Disk::Dir::Entry object with invalid bytes sequence (exactly 30 bytes of binary data retrieved from a physical device are required to initialize it)';
81 0         0 return 0;
82             }
83 103         185 my $convertOK = $self->_bytes_to_data($bytes);
84 103 50       195 return 0 unless $convertOK;
85 103         161 return 1;
86             }
87              
88             sub _bytes_to_data {
89 103     103   154 my $self = shift;
90 103         125 my $bytes = shift;
91             # Get file type:
92 103         182 my $file_type = ord (substr $bytes, 0x00, 0x01);
93             # Get the actual filetype:
94 103         146 my $type = $file_type & 7;
95             # Get closed flag (not set produces "*", or "splat" files):
96 103         136 my $closed = $file_type & 0x80;
97             # Get locked flag (set produces ">" locked files):
98 103         126 my $locked = $file_type & 0x40;
99             # Get track/sector location of first sector of file:
100 103         200 my $track = ord (substr $bytes, 0x01, 0x01);
101 103         143 my $sector = ord (substr $bytes, 0x02, 0x01);
102             # Get 16 character filename (in PETASCII, padded with $A0):
103 103         172 my $rawname = substr $bytes, 0x03, 0x10;
104 103         222 my $name = D64::Disk::Image->name_from_rawname($rawname);
105 103         1035 my ($side_track, $side_sector, $record_length) = ();
106 103 50       248 if ($file_types[$type] eq 'rel') {
107             # Get track/sector location of first side-sector block (REL file only):
108 0         0 $side_track = ord (substr $bytes, 0x13, 0x01);
109 0         0 $side_sector = ord (substr $bytes, 0x14, 0x01);
110             # Get REL file record length (REL file only, maximum value 254):
111 0         0 $record_length = ord (substr $bytes, 0x15, 0x01);
112             }
113             # Get file size in sectors, low/high byte order ($1C+$1D*256):
114 103         218 my $size = ord (substr $bytes, 0x1D, 0x01) << 8 | ord (substr $bytes, 0x1C, 0x01);
115             # Store directory entry details in a hash:
116 103         508 my $dirEntry = {
117             'TYPE' => $type,
118             'CLOSED' => $closed,
119             'LOCKED' => $locked,
120             'TRACK' => $track,
121             'SECTOR' => $sector,
122             'NAME' => $name,
123             'SIDE_TRACK' => $side_track,
124             'SIDE_SECTOR' => $side_sector,
125             'RECORD_LENGTH' => $record_length,
126             'SIZE' => $size,
127             };
128 103         214 $self->{'DETAILS'} = $dirEntry;
129 103         207 return 1;
130             }
131              
132             sub _data_to_bytes {
133 2     2   4 my $self = shift;
134 2         5 my @bytes = ();
135             # Get detailed file information stored within this object instance:
136 2         4 my $dirEntry = $self->{'DETAILS'};
137 2         4 my $type = $dirEntry->{'TYPE'};
138 2         4 my $closed = $dirEntry->{'CLOSED'};
139 2         2 my $locked = $dirEntry->{'LOCKED'};
140 2         4 my $track = $dirEntry->{'TRACK'};
141 2         4 my $sector = $dirEntry->{'SECTOR'};
142 2         6 my $name = $dirEntry->{'NAME'};
143 2   50     8 my $side_track = $dirEntry->{'SIDE_TRACK'} || 0x00;
144 2   50     7 my $side_sector = $dirEntry->{'SIDE_SECTOR'} || 0x00;
145 2   50     7 my $record_length = $dirEntry->{'RECORD_LENGTH'} || 0x00;
146 2         3 my $size = $dirEntry->{'SIZE'};
147             # Byte $00 - File type:
148 2 50       10 $bytes[0x00] = chr ($type | ($locked ? 0x40 : 0x00) | ($closed ? 0x80 : 0x00));
    50          
149             # Byte $01 - Track location of first sector of file:
150 2         4 $bytes[0x01] = chr ($track);
151             # Byte $02 - Sector location of first sector of file:
152 2         4 $bytes[0x02] = chr ($sector);
153             # Bytes $03..$12 - 16 character filename (in PETASCII, padded with $A0):
154 2         6 my $rawname = D64::Disk::Image->rawname_from_name($name);
155 2         21 my $i = 0x03;
156 2         13 foreach my $byte (split //, $rawname) {
157 32         56 $bytes[$i++] = $byte;
158             }
159             # Bytes $13..$14 - Track/Sector location of first side-sector block:
160 2         6 $bytes[0x13] = chr ($side_track);
161 2         3 $bytes[0x14] = chr ($side_sector);
162             # Byte $15 - REL file record length:
163 2         4 $bytes[0x15] = chr ($record_length);
164             # Bytes $16..$1B - Unused
165 2         3 $bytes[0x16] = chr 0x00;
166 2         3 $bytes[0x17] = chr 0x00;
167 2         4 $bytes[0x18] = chr 0x00;
168 2         3 $bytes[0x19] = chr 0x00;
169 2         4 $bytes[0x1A] = chr 0x00;
170 2         3 $bytes[0x1B] = chr 0x00;
171             # Bytes $1C..$1D - File size in sectors, low/high byte order ($1C+$1D*256):
172 2         5 $bytes[0x1C] = chr ($size & 0xFF);
173 2         3 $bytes[0x1D] = chr (($size >> 8) & 0xFF);
174 2         6 my $bytes = join '', @bytes;
175 2         9 return $bytes;
176             }
177              
178             =head2 get_type
179              
180             Get the actual filetype:
181              
182             my $type = $entryObj->get_type();
183              
184             Returns the actual filetype as a three-letter string, the possibilities here are: "del", "seq", "prg", "usr", "rel", "cbm", "dir", and "???".
185              
186             =cut
187              
188             sub get_type {
189 32     32 1 148 my $self = shift;
190 32         66 my $type = $self->{'DETAILS'}->{'TYPE'};
191 32         50 my $file_type = $file_types[$type];
192 32         79 return $file_type;
193             }
194              
195             =head2 set_type
196              
197             Set the actual filetype:
198              
199             my $type = T_DEL;
200             $entryObj->set_type($type);
201              
202             Sets the actual filetype as a symbollic type name, the possibilities here are: C, C, C, C, C, C, and C.
203              
204             =cut
205              
206             sub set_type {
207 2     2 1 42 my ($self, $type) = @_;
208 2 100       7 croak "An illegal file type: ${type}" unless grep { $type == $_ } values %D64::Disk::Dir::file_type_constants;
  16         260  
209 1         7 $self->{'DETAILS'}->{'TYPE'} = $type;
210 1         2 return $type;
211             }
212              
213             =head2 get_closed
214              
215             Get "Closed" flag (when not set produces "*", or "splat" files):
216              
217             my $closed = $entryObj->get_closed();
218              
219             Returns true when "Closed" flag is set, and false otherwise.
220              
221             =cut
222              
223             sub get_closed {
224 22     22 1 48 my $self = shift;
225 22         42 my $closed = $self->{'DETAILS'}->{'CLOSED'};
226 22 100       68 return $closed ? 1 : 0;
227             }
228              
229             =head2 set_closed
230              
231             Set "Closed" flag:
232              
233             $entryObj->set_closed(1);
234              
235             Clear "Closed" flag:
236              
237             $entryObj->set_closed(0);
238              
239             =cut
240              
241             sub set_closed {
242 3     3 1 66 my ($self, $closed) = @_;
243 3 100 66     133 croak "An illegal closed flag: ${closed}" unless $closed == 0 || $closed == 1;
244 2         5 $self->{'DETAILS'}->{'CLOSED'} = $closed;
245 2         118 return $closed;
246             }
247              
248             =head2 get_locked
249              
250             Get "Locked" flag (when set produces ">" locked files):
251              
252             my $locked = $entryObj->get_locked();
253              
254             Returns true when "Locked" flag is set, and false otherwise.
255              
256             =cut
257              
258             sub get_locked {
259 15     15 1 40 my $self = shift;
260 15         26 my $locked = $self->{'DETAILS'}->{'LOCKED'};
261 15 50       36 return $locked ? 1 : 0;
262             }
263              
264             =head2 get_track
265              
266             Get track location of first sector of file:
267              
268             my $track = $entryObj->get_track();
269              
270             =cut
271              
272             sub get_track {
273 24     24 1 54 my $self = shift;
274 24         60 my $track = $self->{'DETAILS'}->{'TRACK'};
275 24         63 return $track;
276             }
277              
278             =head2 set_track
279              
280             Set track location of first sector of file:
281              
282             $entryObj->get_track($track);
283              
284             =cut
285              
286             sub set_track {
287 1     1 1 12 my ($self, $track) = @_;
288 1         4 $self->{'DETAILS'}->{'TRACK'} = $track;
289 1         4 return $track;
290             }
291              
292             =head2 get_sector
293              
294             Get sector location of first sector of file:
295              
296             my $sector = $entryObj->get_sector();
297              
298             =cut
299              
300             sub get_sector {
301 24     24 1 60 my $self = shift;
302 24         36 my $sector = $self->{'DETAILS'}->{'SECTOR'};
303 24         56 return $sector;
304             }
305              
306             =head2 set_sector
307              
308             Set sector location of first sector of file:
309              
310             $entryObj->set_sector($sector);
311              
312             =cut
313              
314             sub set_sector {
315 1     1 1 5 my ($self, $sector) = @_;
316 1         3 $self->{'DETAILS'}->{'SECTOR'} = $sector;
317 1         3 return $sector;
318             }
319              
320             =head2 get_name
321              
322             Get 16 character filename (in PETASCII, padded with $A0):
323              
324             my $convert2ascii = 0;
325             my $name = $entryObj->get_name($convert2ascii);
326              
327             Get filename converted to ASCII string:
328              
329             my $convert2ascii = 1;
330             my $name = $entryObj->get_name($convert2ascii);
331              
332             =cut
333              
334             sub get_name {
335 21     21 1 56 my $self = shift;
336 21         40 my $convert2ascii = shift;
337 21         38 my $name = $self->{'DETAILS'}->{'NAME'};
338 21 100       105 $name = D64::Disk::Image->petscii_to_ascii($name) if $convert2ascii;
339 21         348 return $name;
340             }
341              
342             =head2 get_side_track
343              
344             Get track location of first side-sector block (relative file only):
345              
346             my $side_track = $entryObj->get_side_track();
347              
348             A track location of first side-sector block is returned upon success, an undefined value otherwise.
349              
350             =cut
351              
352             sub get_side_track {
353 1     1 1 963 my $self = shift;
354 1 50       3 if ($self->get_type() ne 'rel') {
355 1         157 carp "Unable to get track location of first side-sector block (not a REL file!)";
356 1         199 return undef;
357             }
358 0         0 my $side_track = $self->{'DETAILS'}->{'SIDE_TRACK'};
359 0         0 return $side_track;
360             }
361              
362             =head2 get_side_sector
363              
364             Get sector location of first side-sector block (relative file only):
365              
366             my $side_sector = $entryObj->get_side_sector();
367              
368             A sector location of first side-sector block is returned upon success, an undefined value otherwise.
369              
370             =cut
371              
372             sub get_side_sector {
373 0     0 1 0 my $self = shift;
374 0 0       0 if ($self->get_type() ne 'rel') {
375 0         0 carp "Unable to get sector location of first side-sector block (not a REL file!)";
376 0         0 return undef;
377             }
378 0         0 my $side_sector = $self->{'DETAILS'}->{'SIDE_SECTOR'};
379 0         0 return $side_sector;
380             }
381              
382             =head2 get_record_length
383              
384             Get relative file record length (relative file only, maximum value 254):
385              
386             my $record_length = $entryObj->get_record_length();
387              
388             A relative file record length is returned upon success, an undefined value otherwise.
389              
390             =cut
391              
392             sub get_record_length {
393 0     0 1 0 my $self = shift;
394 0 0       0 if ($self->get_type() ne 'rel') {
395 0         0 carp "Unable to get relative file record length (not a REL file!)";
396 0         0 return undef;
397             }
398 0         0 my $record_length = $self->{'DETAILS'}->{'RECORD_LENGTH'};
399 0         0 return $record_length;
400             }
401              
402             =head2 get_size
403              
404             Get file size in sectors:
405              
406             my $size = $entryObj->get_size();
407              
408             The approximate filesize in bytes is <= #sectors * 254.
409              
410             =cut
411              
412             sub get_size {
413 18     18 1 223 my $self = shift;
414 18         32 my $size = $self->{'DETAILS'}->{'SIZE'};
415 18         34 return $size;
416             }
417              
418             =head2 get_bytes
419              
420             Get 30 bytes of binary data that would describe this particular directory entry on a D64 disk image (or a physical disk):
421              
422             my $bytes = $entryObj->get_bytes();
423              
424             =cut
425              
426             sub get_bytes {
427 2     2 1 58 my $self = shift;
428 2         6 my $bytes = $self->_data_to_bytes();
429 2         13 return $bytes;
430             }
431              
432             =head2 print_entry
433              
434             Print entry details to any opened file handle (the standard output by default):
435              
436             $entryObj->print_entry($fh, { verbose => $verbose });
437              
438             This method is subsequently invoked for each single entry while printing an entire directory with D64::Disk::Dir module.
439              
440             C defaults to false (changing it to true will additionally print out file's track and sector values).
441              
442             =cut
443              
444             sub print_entry {
445 14     14 1 890 my ($self, $fh, $args) = @_;
446 14 100       34 $fh = *STDOUT unless defined $fh;
447 14 100       30 $args = {} unless defined $args;
448 14         23 my $verbose = $args->{verbose};
449             # Get detailed file information stored within this object instance:
450 14         31 my $type = $self->get_type();
451 14 100       34 my $closed = $self->get_closed() ? ord ' ' : ord '*';
452 14 50       42 my $locked = $self->get_locked() ? ord '<' : ord ' ';
453 14         29 my $size = $self->get_size();
454 14         32 my $track = sprintf '%2d', $self->get_track();
455 14         33 my $sector = sprintf '%2d', $self->get_sector();
456             # Get filename convert to ASCII and add quotes:
457 14         35 my $name = $self->get_name(1);
458 14         62 my $quotename = sprintf "\"%s\"", $name;
459             # Print directory entry:
460 14 100       35 if ($verbose) {
461 6         33 printf $fh "%-4d %-18s%c%s%c %s %s\n", $size, $quotename, $closed, $type, $locked, $track, $sector;
462             }
463             else {
464 8         74 printf $fh "%-4d %-18s%c%s%c\n", $size, $quotename, $closed, $type, $locked;
465             }
466             }
467              
468             =head1 BUGS
469              
470             There are no known bugs at the moment. Please report any bugs or feature requests.
471              
472             =head1 EXPORT
473              
474             None. No method is exported into the caller's namespace either by default or explicitly.
475              
476             =head1 SEE ALSO
477              
478             L, L
479              
480             =head1 AUTHOR
481              
482             Pawel Krol, Epawelkrol@cpan.orgE.
483              
484             =head1 VERSION
485              
486             Version 0.05 (2023-05-14)
487              
488             =head1 COPYRIGHT AND LICENSE
489              
490             This module is licensed under a slightly modified BSD license, the same terms as Per Olofsson's "diskimage.c" library and L Perl package it is based on, license contents are repeated below.
491              
492             Copyright (c) 2003-2006, Per Olofsson
493             All rights reserved.
494              
495             Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
496              
497             =over
498              
499             =item *
500              
501             Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
502              
503             =item *
504              
505             Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
506              
507             =back
508              
509             THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
510              
511             diskimage.c website: L
512              
513             =cut
514              
515             1;