RandomAccess.pm 13 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378
  1. #------------------------------------------------------------------------------
  2. # File: RandomAccess.pm
  3. #
  4. # Description: Buffer to support random access reading of sequential file
  5. #
  6. # Revisions: 02/11/2004 - P. Harvey Created
  7. # 02/20/2004 - P. Harvey Added flag to disable SeekTest in new()
  8. # 11/18/2004 - P. Harvey Fixed bug with seek relative to end of file
  9. # 01/02/2005 - P. Harvey Added DEBUG code
  10. # 01/09/2006 - P. Harvey Fixed bug in ReadLine() when using
  11. # multi-character EOL sequences
  12. # 02/20/2006 - P. Harvey Fixed bug where seek past end of file could
  13. # generate "substr outside string" warning
  14. # 06/10/2006 - P. Harvey Decreased $CHUNK_SIZE from 64k to 8k
  15. # 11/23/2006 - P. Harvey Limit reads to < 0x80000000 bytes
  16. # 11/26/2008 - P. Harvey Fixed bug in ReadLine when reading from a
  17. # scalar with a multi-character newline
  18. # 01/24/2009 - PH Protect against reading too much at once
  19. #
  20. # Notes: Calls the normal file i/o routines unless SeekTest() fails, in
  21. # which case the file is buffered in memory to allow random access.
  22. # SeekTest() is called automatically when the object is created
  23. # unless specified.
  24. #
  25. # May also be used for string i/o (just pass a scalar reference)
  26. #
  27. # Legal: Copyright (c) 2003-2016 Phil Harvey (phil at owl.phy.queensu.ca)
  28. # This library is free software; you can redistribute it and/or
  29. # modify it under the same terms as Perl itself.
  30. #------------------------------------------------------------------------------
  31. package File::RandomAccess;
  32. use strict;
  33. require 5.002;
  34. require Exporter;
  35. use vars qw($VERSION @ISA @EXPORT_OK);
  36. $VERSION = '1.10';
  37. @ISA = qw(Exporter);
  38. sub Read($$$);
  39. # constants
  40. my $CHUNK_SIZE = 8192; # size of chunks to read from file (must be power of 2)
  41. my $SLURP_CHUNKS = 16; # read this many chunks at a time when slurping
  42. #------------------------------------------------------------------------------
  43. # Create new RandomAccess object
  44. # Inputs: 0) reference to RandomAccess object or RandomAccess class name
  45. # 1) file reference or scalar reference
  46. # 2) flag set if file is already random access (disables automatic SeekTest)
  47. sub new($$;$)
  48. {
  49. my ($that, $filePt, $isRandom) = @_;
  50. my $class = ref($that) || $that;
  51. my $self;
  52. if (ref $filePt eq 'SCALAR') {
  53. # string i/o
  54. $self = {
  55. BUFF_PT => $filePt,
  56. POS => 0,
  57. LEN => length($$filePt),
  58. TESTED => -1,
  59. };
  60. bless $self, $class;
  61. } else {
  62. # file i/o
  63. my $buff = '';
  64. $self = {
  65. FILE_PT => $filePt, # file pointer
  66. BUFF_PT => \$buff, # reference to file data
  67. POS => 0, # current position in file
  68. LEN => 0, # data length
  69. TESTED => 0, # 0=untested, 1=passed, -1=failed (requires buffering)
  70. };
  71. bless $self, $class;
  72. $self->SeekTest() unless $isRandom;
  73. }
  74. return $self;
  75. }
  76. #------------------------------------------------------------------------------
  77. # Enable DEBUG code
  78. # Inputs: 0) reference to RandomAccess object
  79. sub Debug($)
  80. {
  81. my $self = shift;
  82. $self->{DEBUG} = { };
  83. }
  84. #------------------------------------------------------------------------------
  85. # Perform seek test and turn on buffering if necessary
  86. # Inputs: 0) reference to RandomAccess object
  87. # Returns: 1 if seek test passed (ie. no buffering required)
  88. # Notes: Must be done before any other i/o
  89. sub SeekTest($)
  90. {
  91. my $self = shift;
  92. unless ($self->{TESTED}) {
  93. my $fp = $self->{FILE_PT};
  94. if (seek($fp, 1, 1) and seek($fp, -1, 1)) {
  95. $self->{TESTED} = 1; # test passed
  96. } else {
  97. $self->{TESTED} = -1; # test failed (requires buffering)
  98. }
  99. }
  100. return $self->{TESTED} == 1 ? 1 : 0;
  101. }
  102. #------------------------------------------------------------------------------
  103. # Get current position in file
  104. # Inputs: 0) reference to RandomAccess object
  105. # Returns: current position in file
  106. sub Tell($)
  107. {
  108. my $self = shift;
  109. my $rtnVal;
  110. if ($self->{TESTED} < 0) {
  111. $rtnVal = $self->{POS};
  112. } else {
  113. $rtnVal = tell($self->{FILE_PT});
  114. }
  115. return $rtnVal;
  116. }
  117. #------------------------------------------------------------------------------
  118. # Seek to position in file
  119. # Inputs: 0) reference to RandomAccess object
  120. # 1) position, 2) whence (0 or undef=from start, 1=from cur pos, 2=from end)
  121. # Returns: 1 on success
  122. # Notes: When buffered, this doesn't quite behave like seek() since it will return
  123. # success even if you seek outside the limits of the file. However if you
  124. # do this, you will get an error on your next Read().
  125. sub Seek($$;$)
  126. {
  127. my ($self, $num, $whence) = @_;
  128. $whence = 0 unless defined $whence;
  129. my $rtnVal;
  130. if ($self->{TESTED} < 0) {
  131. my $newPos;
  132. if ($whence == 0) {
  133. $newPos = $num; # from start of file
  134. } elsif ($whence == 1) {
  135. $newPos = $num + $self->{POS}; # relative to current position
  136. } else {
  137. $self->Slurp(); # read whole file into buffer
  138. $newPos = $num + $self->{LEN}; # relative to end of file
  139. }
  140. if ($newPos >= 0) {
  141. $self->{POS} = $newPos;
  142. $rtnVal = 1;
  143. }
  144. } else {
  145. $rtnVal = seek($self->{FILE_PT}, $num, $whence);
  146. }
  147. return $rtnVal;
  148. }
  149. #------------------------------------------------------------------------------
  150. # Read from the file
  151. # Inputs: 0) reference to RandomAccess object, 1) buffer, 2) bytes to read
  152. # Returns: Number of bytes read
  153. sub Read($$$)
  154. {
  155. my $self = shift;
  156. my $len = $_[1];
  157. my $rtnVal;
  158. # protect against reading too much at once
  159. # (also from dying with a "Negative length" error)
  160. if ($len & 0xf8000000) {
  161. return 0 if $len < 0;
  162. # read in smaller blocks because Windows attempts to pre-allocate
  163. # memory for the full size, which can lead to an out-of-memory error
  164. my $maxLen = 0x4000000; # (MUST be less than bitmask in "if" above)
  165. my $num = Read($self, $_[0], $maxLen);
  166. return $num if $num < $maxLen;
  167. for (;;) {
  168. $len -= $maxLen;
  169. last if $len <= 0;
  170. my $l = $len < $maxLen ? $len : $maxLen;
  171. my $buff;
  172. my $n = Read($self, $buff, $l);
  173. last unless $n;
  174. $_[0] .= $buff;
  175. $num += $n;
  176. last if $n < $l;
  177. }
  178. return $num;
  179. }
  180. # read through our buffer if necessary
  181. if ($self->{TESTED} < 0) {
  182. my $buff;
  183. my $newPos = $self->{POS} + $len;
  184. # number of bytes to read from file
  185. my $num = $newPos - $self->{LEN};
  186. if ($num > 0 and $self->{FILE_PT}) {
  187. # read data from file in multiples of $CHUNK_SIZE
  188. $num = (($num - 1) | ($CHUNK_SIZE - 1)) + 1;
  189. $num = read($self->{FILE_PT}, $buff, $num);
  190. if ($num) {
  191. ${$self->{BUFF_PT}} .= $buff;
  192. $self->{LEN} += $num;
  193. }
  194. }
  195. # number of bytes left in data buffer
  196. $num = $self->{LEN} - $self->{POS};
  197. if ($len <= $num) {
  198. $rtnVal = $len;
  199. } elsif ($num <= 0) {
  200. $_[0] = '';
  201. return 0;
  202. } else {
  203. $rtnVal = $num;
  204. }
  205. # return data from our buffer
  206. $_[0] = substr(${$self->{BUFF_PT}}, $self->{POS}, $rtnVal);
  207. $self->{POS} += $rtnVal;
  208. } else {
  209. # read directly from file
  210. $_[0] = '' unless defined $_[0];
  211. $rtnVal = read($self->{FILE_PT}, $_[0], $len) || 0;
  212. }
  213. if ($self->{DEBUG}) {
  214. my $pos = $self->Tell() - $rtnVal;
  215. unless ($self->{DEBUG}->{$pos} and $self->{DEBUG}->{$pos} > $rtnVal) {
  216. $self->{DEBUG}->{$pos} = $rtnVal;
  217. }
  218. }
  219. return $rtnVal;
  220. }
  221. #------------------------------------------------------------------------------
  222. # Read a line from file (end of line is $/)
  223. # Inputs: 0) reference to RandomAccess object, 1) buffer
  224. # Returns: Number of bytes read
  225. sub ReadLine($$)
  226. {
  227. my $self = shift;
  228. my $rtnVal;
  229. my $fp = $self->{FILE_PT};
  230. if ($self->{TESTED} < 0) {
  231. my ($num, $buff);
  232. my $pos = $self->{POS};
  233. if ($fp) {
  234. # make sure we have some data after the current position
  235. while ($self->{LEN} <= $pos) {
  236. $num = read($fp, $buff, $CHUNK_SIZE);
  237. return 0 unless $num;
  238. ${$self->{BUFF_PT}} .= $buff;
  239. $self->{LEN} += $num;
  240. }
  241. # scan and read until we find the EOL (or hit EOF)
  242. for (;;) {
  243. $pos = index(${$self->{BUFF_PT}}, $/, $pos);
  244. if ($pos >= 0) {
  245. $pos += length($/);
  246. last;
  247. }
  248. $pos = $self->{LEN}; # have scanned to end of buffer
  249. $num = read($fp, $buff, $CHUNK_SIZE) or last;
  250. ${$self->{BUFF_PT}} .= $buff;
  251. $self->{LEN} += $num;
  252. }
  253. } else {
  254. # string i/o
  255. $pos = index(${$self->{BUFF_PT}}, $/, $pos);
  256. if ($pos < 0) {
  257. $pos = $self->{LEN};
  258. $self->{POS} = $pos if $self->{POS} > $pos;
  259. } else {
  260. $pos += length($/);
  261. }
  262. }
  263. # read the line from our buffer
  264. $rtnVal = $pos - $self->{POS};
  265. $_[0] = substr(${$self->{BUFF_PT}}, $self->{POS}, $rtnVal);
  266. $self->{POS} = $pos;
  267. } else {
  268. $_[0] = <$fp>;
  269. if (defined $_[0]) {
  270. $rtnVal = length($_[0]);
  271. } else {
  272. $rtnVal = 0;
  273. }
  274. }
  275. if ($self->{DEBUG}) {
  276. my $pos = $self->Tell() - $rtnVal;
  277. unless ($self->{DEBUG}->{$pos} and $self->{DEBUG}->{$pos} > $rtnVal) {
  278. $self->{DEBUG}->{$pos} = $rtnVal;
  279. }
  280. }
  281. return $rtnVal;
  282. }
  283. #------------------------------------------------------------------------------
  284. # Read whole file into buffer (without changing read pointer)
  285. # Inputs: 0) reference to RandomAccess object
  286. sub Slurp($)
  287. {
  288. my $self = shift;
  289. my $fp = $self->{FILE_PT} || return;
  290. # read whole file into buffer (in large chunks)
  291. my ($buff, $num);
  292. while (($num = read($fp, $buff, $CHUNK_SIZE * $SLURP_CHUNKS)) != 0) {
  293. ${$self->{BUFF_PT}} .= $buff;
  294. $self->{LEN} += $num;
  295. }
  296. }
  297. #------------------------------------------------------------------------------
  298. # set binary mode
  299. # Inputs: 0) reference to RandomAccess object
  300. sub BinMode($)
  301. {
  302. my $self = shift;
  303. binmode($self->{FILE_PT}) if $self->{FILE_PT};
  304. }
  305. #------------------------------------------------------------------------------
  306. # close the file and free the buffer
  307. # Inputs: 0) reference to RandomAccess object
  308. sub Close($)
  309. {
  310. my $self = shift;
  311. if ($self->{DEBUG}) {
  312. local $_;
  313. if ($self->Seek(0,2)) {
  314. $self->{DEBUG}->{$self->Tell()} = 0; # set EOF marker
  315. my $last;
  316. my $tot = 0;
  317. my $bad = 0;
  318. foreach (sort { $a <=> $b } keys %{$self->{DEBUG}}) {
  319. my $pos = $_;
  320. my $len = $self->{DEBUG}->{$_};
  321. if (defined $last and $last < $pos) {
  322. my $bytes = $pos - $last;
  323. $tot += $bytes;
  324. $self->Seek($last);
  325. my $buff;
  326. $self->Read($buff, $bytes);
  327. my $warn = '';
  328. if ($buff =~ /[^\0]/) {
  329. $bad += ($pos - $last);
  330. $warn = ' - NON-ZERO!';
  331. }
  332. printf "0x%.8x - 0x%.8x (%d bytes)$warn\n", $last, $pos, $bytes;
  333. }
  334. my $cur = $pos + $len;
  335. $last = $cur unless defined $last and $last > $cur;
  336. }
  337. print "$tot bytes missed";
  338. $bad and print ", $bad non-zero!";
  339. print "\n";
  340. } else {
  341. warn "File::RandomAccess DEBUG not working (file already closed?)\n";
  342. }
  343. delete $self->{DEBUG};
  344. }
  345. # close the file
  346. if ($self->{FILE_PT}) {
  347. close($self->{FILE_PT});
  348. delete $self->{FILE_PT};
  349. }
  350. # reset the buffer
  351. my $emptyBuff = '';
  352. $self->{BUFF_PT} = \$emptyBuff;
  353. $self->{LEN} = 0;
  354. $self->{POS} = 0;
  355. }
  356. #------------------------------------------------------------------------------
  357. 1; # end