File Coverage

blib/lib/D64/Disk/Layout/Base.pm
Criterion Covered Total %
statement 145 182 79.6
branch 35 60 58.3
condition 14 48 29.1
subroutine 15 17 88.2
pod 6 6 100.0
total 215 313 68.6


line stmt bran cond sub pod time code
1             package D64::Disk::Layout::Base;
2              
3             =head1 NAME
4              
5             D64::Disk::Layout::Base - A base class for designing physical layouts of various Commodore disk image formats
6              
7             =head1 SYNOPSIS
8              
9             package D64::MyLayout;
10              
11             # Establish an ISA relationship with base class:
12             use base qw(D64::Disk::Layout::Base);
13              
14             # Number of bytes per sector storage:
15             our $bytes_per_sector = 256;
16              
17             # Number of sectors per track storage:
18             our @sectors_per_track = ( 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, # tracks 1-17
19             19, 19, 19, 19, 19, 19, 19, # tracks 18-24
20             18, 18, 18, 18, 18, 18, # tracks 25-30
21             17, 17, 17, 17, 17, 17, 17, 17, 17, 17 # tracks 31-40
22             );
23              
24             # Override default object constructor:
25             sub new {
26             my $class = shift;
27             my $self = $class->SUPER::new(@_);
28             if (defined $self) {
29             bless $self, $class;
30             return $self;
31             }
32             else {
33             warn 'Failed to create new D64::MyLayout object';
34             return undef;
35             }
36             }
37              
38             package main;
39              
40             # Read disk image data from file and create new derived class object instance:
41             my $diskLayoutObj = D64::MyLayout->new('image.d64');
42              
43             # Get number of tracks available for use:
44             my $num_tracks = $diskLayoutObj->num_tracks();
45             # Get number of sectors per track information:
46             my $num_sectors = $diskLayoutObj->num_sectors($track);
47              
48             # Read physical sector data from disk image:
49             my $data = $diskLayoutObj->sector_data($track, $sector);
50             my @data = $diskLayoutObj->sector_data($track, $sector);
51              
52             # Write physical sector data into disk image:
53             $diskLayoutObj->sector_data($track, $sector, $data);
54             $diskLayoutObj->sector_data($track, $sector, @data);
55              
56             # Save data changes to file:
57             $diskLayoutObj->save();
58             $diskLayoutObj->save_as('image.d64');
59              
60             =head1 DESCRIPTION
61              
62             This package provides a base class for designing physical layouts of various Commodore disk image formats, represented by data that can be allocated into tracks and sectors. The following two variables are required to be defined at a package-scope level of any derived class:
63              
64             our $bytes_per_sector = 256;
65              
66             This scalar value defines number of bytes per sector storage.
67              
68             our @sectors_per_track = ( 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, # tracks 1-17
69             19, 19, 19, 19, 19, 19, 19, # tracks 18-24
70             18, 18, 18, 18, 18, 18, # tracks 25-30
71             17, 17, 17, 17, 17, 17, 17, 17, 17, 17 # tracks 31-40
72             );
73              
74             This list defines number of sectors per track storage.
75              
76             Initialization of both these properties is always validated at compile-time within import method of the base class.
77              
78             =head1 METHODS
79              
80             =cut
81              
82 2     2   46261 use bytes;
  2         23  
  2         13  
83 2     2   61 use strict;
  2         3  
  2         72  
84 2     2   11 use warnings;
  2         10  
  2         62  
85              
86 2     2   10 use base qw(Exporter);
  2         3  
  2         387  
87             our %EXPORT_TAGS = ();
88             $EXPORT_TAGS{'all'} = [];
89             our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
90             our @EXPORT = qw();
91              
92             our $VERSION = '0.01';
93              
94 2     2   11 use Carp qw(carp croak);
  2         6  
  2         4273  
95              
96             sub import {
97 0     0   0 my $this = shift;
98 0   0     0 my $class = ref($this) || $this;
99 0         0 my $bytes_per_sector = $class->_derived_class_property_value('$bytes_per_sector');
100 0 0       0 croak "Derived class \"${class}\" does not define \"\$bytes_per_sector\" value" unless defined $bytes_per_sector;
101 0         0 my $sectors_per_track_aref = $class->_derived_class_property_value('@sectors_per_track');
102 0 0       0 croak "Derived class \"${class}\" does not define \"\@sectors_per_track\" array" unless defined $sectors_per_track_aref;
103             # $class->_track_data_offsets($bytes_per_sector, $sectors_per_track_aref);
104 0         0 $class->SUPER::import();
105             }
106              
107             =head2 new
108              
109             Create empty unformatted disk image layout:
110              
111             my $diskLayoutObj = D64::Disk::Layout::Base->new();
112              
113             Read disk image layout from existing file:
114              
115             my $diskLayoutObj = D64::Disk::Layout::Base->new('image.d64');
116              
117             A valid D64::Disk::Layout::Base object is returned upon success, an undefined value otherwise.
118              
119             You are most likely wanting to override this method in your derived class source code by calling it first to create an object and then reblessing a referenced object currently belonging to the base class:
120              
121             use base qw(D64::Disk::Layout::Base);
122              
123             sub new {
124             my $class = shift;
125             my $self = $class->SUPER::new(@_);
126             if (defined $self) {
127             bless $self, $class;
128             return $self;
129             }
130             else {
131             warn 'Failed to create new D64::MyLayout object';
132             return undef;
133             }
134             }
135              
136             Creating a new object may fail upon one of the following conditions:
137              
138             =over
139              
140             =item *
141             File specified as an input parameter does not exist or cannot be read
142              
143             =item *
144             File is too short, what causes inability to read complete sector data
145              
146             =back
147              
148             =cut
149              
150             sub new {
151 19     19 1 2006378 my $this = shift;
152 19   33     93 my $class = ref($this) || $this;
153 19         43 my $self = {};
154 19         60 bless $self, $class;
155 19         53 my $initOK = $self->_initialize(@_);
156 19 50       35 if ($initOK) {
157 19         56 return $self;
158             }
159             else {
160 0         0 return undef;
161             }
162             }
163              
164             sub _initialize {
165 19     19   27 my $self = shift;
166 19         24 my $filename = shift;
167 19 100       43 if (defined $filename) {
168             # Validate that file exists:
169 2 50       64 unless (-e $filename) {
170 0         0 carp "File \"${filename}\" does not exist";
171 0         0 return 0;
172             }
173 2 50       43 unless (-r $filename) {
174 0         0 carp "Unable to open file \"${filename}\" for reading";
175 0         0 return 0;
176             }
177             # Read disk image data from file:
178 2         12 my $readOK = $self->_read_image_data($filename);
179 2 50       7 return 0 unless $readOK;
180             }
181             else {
182             # Create new empty disk image:
183 17         36 $self->_create_empty_image();
184             }
185 19         34 return 1;
186             }
187              
188             sub _create_empty_image {
189 17     17   21 my $self = shift;
190 17   33     40 my $class = ref($self) || $self;
191 17         46 my $bytes_per_sector = $class->_derived_class_property_value('$bytes_per_sector');
192 17         60 my $sectors_per_track_aref = $class->_derived_class_property_value('@sectors_per_track');
193             # Generate track data:
194 17         33 my $num_tracks = @{$sectors_per_track_aref};
  17         27  
195 17         49 for (my $track = 1; $track <= $num_tracks; $track++) {
196             # Generate sector data:
197 66         94 my $num_sectors = $sectors_per_track_aref->[$track - 1];
198 66         122 for (my $sector = 0; $sector < $num_sectors; $sector++) {
199 150         204 my $buffer = chr (0x00) x $bytes_per_sector;
200 150         277 $self->sector_data($track, $sector, $buffer);
201             }
202             }
203             }
204              
205             sub _read_image_data {
206 2     2   5 my $self = shift;
207 2         3 my $filename = shift;
208 2   33     11 my $class = ref($self) || $self;
209 2         12 my $bytes_per_sector = $class->_derived_class_property_value('$bytes_per_sector');
210 2         12 my $sectors_per_track_aref = $class->_derived_class_property_value('@sectors_per_track');
211             # my $track_data_offsets_aref = $class->_derived_class_property_value('@track_data_offsets');
212             # Open file for reading:
213 2 50       102 open (my $fh, '<', $filename) or croak $!;
214 2         8 binmode $fh;
215             # Read track data:
216 2         3 my $num_tracks = @{$sectors_per_track_aref};
  2         5  
217 2         7 for (my $track = 1; $track <= $num_tracks; $track++) {
218             # Read sector data:
219 10         20 my $num_sectors = $sectors_per_track_aref->[$track - 1];
220 10         23 for (my $sector = 0; $sector < $num_sectors; $sector++) {
221 24         22 my $buffer;
222             # my $offset = $track_data_offsets_aref->[$track - 1] + $sector * $bytes_per_sector;
223 24         190 my $num_bytes = sysread ($fh, $buffer, $bytes_per_sector);
224 24 50 0     50 if ($num_bytes == $bytes_per_sector) {
    0          
225 24         59 $self->sector_data($track, $sector, $buffer);
226             }
227             elsif ($num_bytes > 0 and $num_bytes != $bytes_per_sector) {
228 0         0 croak "Number of bytes read from disk image \"${filename}\" on track ${track} and sector ${sector} is ${num_bytes} when ${bytes_per_sector} bytes were expected (file too short?)";
229             }
230             }
231             }
232             # Close file upon reading:
233 2 50       56 close ($fh) or croak $!;
234             # Keep the name of file read for further data saving actions:
235 2         13 $self->{'FILE'} = $filename;
236             }
237              
238             =head2 sector_data
239              
240             Read physical sector data from disk image:
241              
242             my $data = $diskLayoutObj->sector_data($track, $sector);
243             my @data = $diskLayoutObj->sector_data($track, $sector);
244              
245             Can either be read into a scalar (in which case it is a bytes sequence) or into an array (method called in a list context returns a list of single bytes of data). Length of a scalar as well as size of an array depends on number of bytes per sector storage defined within derived class in $bytes_per_sector variable.
246              
247             A valid sector data is returned upon successful read, an undefined value otherwise.
248              
249             Write physical sector data into disk image:
250              
251             $diskLayoutObj->sector_data($track, $sector, $data);
252             $diskLayoutObj->sector_data($track, $sector, @data);
253              
254             Same as above, data to write can be provided as a scalar (a bytes sequence of strictly defined length) as well as an array (list of single bytes of data of precisely specified size).
255              
256             A valid sector data is returned upon successful write, an undefined value otherwise.
257              
258             =cut
259              
260             sub sector_data {
261 242     242 1 448 my $self = shift;
262 242         233 my $track = shift;
263 242         204 my $sector = shift;
264 242         492 my @data = splice @_;
265 242   33     520 my $class = ref($self) || $self;
266 242         208 my $data;
267 242         835 $data .= $_ for @data;
268             # Validate track number (should be within range 1 .. $num_tracks):
269 242         516 my $sectors_per_track_aref = $class->_derived_class_property_value('@sectors_per_track');
270 242         471 my $num_tracks = @{$sectors_per_track_aref};
  242         354  
271 242 50 33     1545 if ($track < 1 or $track > $num_tracks) {
272 0         0 carp "Invalid track number: ${track} (accepted track number range for this class is: 1 <= \$track <= ${num_tracks})";
273 0         0 return undef;
274             }
275             # Validate sector number (should be within range 0 .. $num_sectors - 1):
276 242         531 my $num_sectors = $self->num_sectors($track);
277 242 50 33     892 if ($sector < 0 or $sector >= $num_sectors) {
278 0         0 carp "Invalid sector number: ${sector} (accepted sector number range for this class is: 0 <= \$sector < ${num_sectors})";
279 0         0 return undef;
280             }
281 242 100       471 if (defined $data) {
282 179         932 my $bytes_per_sector = $class->_derived_class_property_value('$bytes_per_sector');
283 179         359 my $data_length = length $data;
284             # Validate data length (should contain exactly "$bytes_per_sector" bytes):
285 179 100       403 if ($data_length > $bytes_per_sector) {
286 1         2 my $bytes_truncated = $data_length - $bytes_per_sector;
287 1         3 substr $data, $bytes_per_sector, $bytes_truncated, '';
288 1         135 carp "Too much data provided while writing physical sector into disk image, last ${bytes_truncated} byte(s) of data truncated and just ${bytes_per_sector} byte(s) written";
289             }
290             # Pad data to be written to disk with zeroes (uninitialized values):
291 179 100       332 if ($data_length < $bytes_per_sector) {
292 1         2 my $bytes_appended = $bytes_per_sector - $data_length;
293 1         4 substr $data, $data_length, 0, chr (0x00) x $bytes_appended;
294 1         240 carp "Too little data provided while writing physical sector into disk image, ${bytes_appended} extra zero byte(s) of data appended and ${bytes_per_sector} byte(s) written";
295             }
296 179         545 $self->{'DATA'}->[$track]->[$sector] = $data;
297             }
298 242 100       4114 return unless defined wantarray;
299 68         120 $data = $self->{'DATA'}->[$track]->[$sector];
300 68 100       115 if (wantarray) {
301 24         126 @data = split //, $data;
302 24         106 return @data;
303             }
304             else {
305 44         125 return $data;
306             }
307             }
308              
309             sub _track_data_offsets {
310 0     0   0 my ($class, $bytes_per_sector, $sectors_per_track_aref) = splice @_;
311 0         0 my @track_data_offsets = ();
312 0         0 my $offset = 0;
313 0         0 my $num_tracks = @{$sectors_per_track_aref};
  0         0  
314 0         0 for (my $track = 0; $track < $num_tracks; $track++) {
315 0         0 push @track_data_offsets, $offset;
316 0         0 $offset += $sectors_per_track_aref->[$track] * $bytes_per_sector;
317             }
318 0         0 $class->_derived_class_property_value('@track_data_offsets', \@track_data_offsets);
319             }
320              
321             sub _derived_class_property_value {
322 720     720   821 my $this = shift;
323 720         950 my $param = shift;
324 720         883 my $value = shift;
325 720   33     2221 my $class = ref($this) || $this;
326 720         2303 $param =~ s/^(.)//;
327 720         1188 my $type = $+;
328 720 100       2014 if ($type eq '$') {
    50          
329 202 50       273 unless (defined $value) {
330 202         8795 return eval "\$${class}::${param}";
331             }
332             else {
333 0         0 return eval "\$${class}::${param} = \$value";
334             }
335             }
336             elsif ($type eq '@') {
337 518 50       773 unless (defined $value) {
338 518         24723 return eval "\\\@${class}::${param}";
339             }
340             else {
341 0         0 return eval "\@${class}::${param} = \@{\$value}";
342             }
343             }
344 0         0 return undef;
345             }
346              
347             =head2 num_tracks
348              
349             Get number of tracks available:
350              
351             my $num_tracks = $diskLayoutObj->num_tracks();
352              
353             =cut
354              
355             sub num_tracks {
356 2     2 1 20 my $self = shift;
357 2   33     6 my $class = ref($self) || $self;
358 2         5 my $sectors_per_track_aref = $class->_derived_class_property_value('@sectors_per_track');
359 2         4 my $num_tracks = @{$sectors_per_track_aref};
  2         4  
360 2         4 return $num_tracks;
361             }
362              
363             =head2 num_sectors
364              
365             Get number of sectors per track:
366              
367             my $num_sectors = $diskLayoutObj->num_sectors($track);
368              
369             Number of sectors per specified track is returned upon success, an undefined value otherwise.
370              
371             =cut
372              
373             sub num_sectors {
374 251     251 1 318 my $self = shift;
375 251         233 my $track = shift;
376 251   33     522 my $class = ref($self) || $self;
377 251         633 my $sectors_per_track_aref = $class->_derived_class_property_value('@sectors_per_track');
378 251         471 my $num_tracks = @{$sectors_per_track_aref};
  251         362  
379 251 50 33     1578 if ($track < 1 or $track > $num_tracks) {
380 0         0 carp "Invalid track number: ${track} (accepted track number range for this class is: 1 <= \$track <= ${num_tracks})";
381 0         0 return undef;
382             }
383 251         370 my $num_sectors = $sectors_per_track_aref->[$track - 1];
384 251         515 return $num_sectors;
385             }
386              
387             =head2 save
388              
389             Save disk layout data to previously loaded image file:
390              
391             my $saveOK = $diskLayoutObj->save();
392              
393             This method will not work when layout object is created as an empty unformatted disk image. Creating empty unformatted disk image layout forces usage of "save_as" method to save data by providing a filename to create new file. Disk layout object needs to be created by reading disk image layout from existing file to make this particular subroutine operative.
394              
395             Returns true value upon successful write, and false otherwise.
396              
397             =cut
398              
399             sub save {
400 2     2 1 1611 my $self = shift;
401 2         7 my $filename = $self->{'FILE'};
402 2 100       10 unless (defined $filename) {
403 1         197 carp "This disk layout object has been created as an empty unformatted disk image without a filename specified during its creation. You need to use 'save_as' method in order to provide a filename to create new file instead";
404 1         30 return 0;
405             }
406 1         12 my $saveOK = $self->save_as($filename);
407 1         4 return $saveOK;
408             }
409              
410             =head2 save_as
411              
412             Save disk layout data to file with specified name:
413              
414             my $saveOK = $diskLayoutObj->save_as('image.d64');
415              
416             A behaviour implemented in this method prevents from overwriting an existing file unless it is the same file as the one that data has been previously read from (the same file that was used while creating this object instance).
417              
418             Returns true value upon successful write, and false otherwise.
419              
420             =cut
421              
422             sub save_as {
423 4     4 1 26 my $self = shift;
424 4         10 my $filename = shift;
425 4   33     18 my $class = ref($self) || $self;
426             # Test if provided filename is the same as file loaded during initialization:
427 4         8 my $loaded_filename = $self->{'FILE'};
428 4 100 66     22 unless (defined $loaded_filename and $loaded_filename eq $filename) {
429             # Validate that target file does not exist yet:
430 3 50       65 if (-e $filename) {
431 0         0 carp "Unable to save disk layout data. Target file \"${filename}\" already exists";
432 0         0 return 0;
433             }
434             }
435             # If both names are the same, there is no need to validate file existence,
436             # because in such case we allow to overwrite original file with new data!
437 4         12 my $bytes_per_sector = $class->_derived_class_property_value('$bytes_per_sector');
438 4         17 my $sectors_per_track_aref = $class->_derived_class_property_value('@sectors_per_track');
439             # Open file for writing:
440 4 50       538 open (my $fh, '>', $filename) or croak $!;
441 4         11 binmode $fh;
442             # Write track data:
443 4         8 my $num_tracks = @{$sectors_per_track_aref};
  4         9  
444 4         19 for (my $track = 1; $track <= $num_tracks; $track++) {
445             # Write sector data:
446 18         31 my $num_sectors = $sectors_per_track_aref->[$track - 1];
447 18         39 for (my $sector = 0; $sector < $num_sectors; $sector++) {
448 42         159 my $data = $self->sector_data($track, $sector);
449             # my $offset = $track_data_offsets_aref->[$track - 1] + $sector * $bytes_per_sector;
450 42         660 my $num_bytes = syswrite ($fh, $data, $bytes_per_sector);
451 42 50 33     260 unless (defined $num_bytes and $num_bytes == $bytes_per_sector) {
452 0         0 carp "There was a problem writing data to file \"${filename}\": $!";
453 0         0 close $fh;
454 0 0 0     0 unlink $filename if defined $loaded_filename and $loaded_filename ne $filename;
455 0         0 return 0;
456             }
457             }
458             }
459             # Close file upon reading:
460 4 50       79 close ($fh) or croak $!;
461             # Keep the name of file read for further data saving actions:
462 4         10 $self->{'FILE'} = $filename;
463 4         19 return 1;
464             }
465              
466             =head1 BUGS
467              
468             There are no known bugs at the moment. Please report any bugs or feature requests.
469              
470             =head1 EXPORT
471              
472             None. No method is exported into the caller's namespace either by default or explicitly.
473              
474             =head1 SEE ALSO
475              
476             L
477              
478             =head1 AUTHOR
479              
480             Pawel Krol, Epawelkrol@cpan.orgE.
481              
482             =head1 VERSION
483              
484             Version 0.01 (2011-01-22)
485              
486             =head1 COPYRIGHT AND LICENSE
487              
488             Copyright 2011 by Pawel Krol .
489              
490             This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
491              
492             =cut
493              
494             1;