Import Upstream version 2.0.8
Dirk Eddelbuettel
5 years ago
| 0 | 2005-08-31 12:25 nj7w(Nitin Jain) | |
| 1 | ||
| 2 | * DESCRIPTION: Added DESCRIPTION file | |
| 3 | ||
| 4 | 2005-08-31 12:22 nj7w(Nitin Jain) | |
| 5 | ||
| 6 | * DESCRIPTION.in: removed DESCRIPTION.in | |
| 7 | ||
| 8 | 2005-07-20 17:06 nj7w(Nitin Jain) | |
| 9 | ||
| 10 | * man/ll.Rd: updated documentation | |
| 11 | ||
| 12 | 2005-07-20 17:05 nj7w(Nitin Jain) | |
| 13 | ||
| 14 | * R/Args.R: ## Args() was using a different search path from | |
| 15 | args(), e.g. rep <- function(local) return(NULL) args() Args() | |
| 16 | ## Fixed | |
| 17 | ||
| 18 | 2005-07-20 17:05 nj7w(Nitin Jain) | |
| 19 | ||
| 20 | * R/is.what.R: ## is.what() was giving needless warnings for | |
| 21 | functions, e.g. is.what(plot) ## Fixed | |
| 22 | ||
| 23 | 2005-07-20 17:04 nj7w(Nitin Jain) | |
| 24 | ||
| 25 | * R/ll.R: ## ll() was crashing if argument was a list of length | |
| 26 | zero, e.g. x <- list() ll(x) ## Fixed, and added sort.elements | |
| 27 | (see new help page) | |
| 28 | ||
| 29 | 2005-06-09 10:20 nj7w(Nitin Jain) | |
| 30 | ||
| 31 | * R/Args.R, R/aggregate.table.R, R/combine.R, R/elem.R, R/env.R, | |
| 32 | R/frameApply.R, R/interleave.R, R/is.what.R, R/keep.R, R/ll.R, | |
| 33 | R/matchcols.R, R/nobs.R, R/read.xls.R, R/rename.vars.R, | |
| 34 | R/reorder.R, R/trim.R, R/unmatrix.R, inst/perl/IO/AtomicFile.pm, | |
| 35 | inst/perl/IO/InnerFile.pm, inst/perl/IO/Lines.pm, | |
| 36 | inst/perl/IO/Scalar.pm, inst/perl/IO/Scalar.pm.html, | |
| 37 | inst/perl/IO/ScalarArray.pm, inst/perl/IO/Stringy.pm, | |
| 38 | inst/perl/IO/Wrap.pm, inst/perl/IO/WrapTie.pm, | |
| 39 | man/aggregate.table.Rd, man/combine.Rd, man/drop.levels.Rd, | |
| 40 | man/interleave.Rd, man/nobs.Rd, man/rename.vars.Rd, | |
| 41 | man/reorder.Rd: Updating the version number, and various help | |
| 42 | files to synchronize splitting of gregmisc bundle in 4 individual | |
| 43 | components. | |
| 44 | ||
| 45 | 2005-06-07 15:51 nj7w(Nitin Jain) | |
| 46 | ||
| 47 | * R/drop.levels.R: Reverting to the previous version of | |
| 48 | drop.levels.R by replacing sapply(...) with | |
| 49 | as.data.frame(lapply(...)) because sapply has the undesirable | |
| 50 | effect of converting the object to a matrix, which in turn | |
| 51 | coerces the factors to numeric. | |
| 52 | ||
| 53 | 2005-05-13 14:59 nj7w(Nitin Jain) | |
| 54 | ||
| 55 | * R/read.xls.R: 1) Using dQuote.ascii function in read.xls as the | |
| 56 | new version of dQuote doesn't work proprly with UTF-8 locale. 2) | |
| 57 | Modified CrossTable.Rd usage in gmodels 3) Modified heatmap.2 | |
| 58 | usage in gplots. | |
| 59 | ||
| 60 | 2005-04-01 23:19 tag release_2_0_5 | |
| 61 | ||
| 62 | 2005-04-01 23:19 tag release_2_0_6 | |
| 63 | ||
| 64 | 2005-04-01 23:19 warnes | |
| 65 | ||
| 66 | * NAMESPACE, R/drop.levels.R, man/drop.levels.Rd: Move | |
| 67 | drop.levels() from gtools to gdata. | |
| 68 | ||
| 69 | 2005-04-01 23:14 warnes | |
| 70 | ||
| 71 | * NAMESPACE, R/frameApply.R, man/frameApply.Rd: Move frameApply() | |
| 72 | to gdata package. | |
| 73 | ||
| 74 | 2005-03-31 13:11 warnes | |
| 75 | ||
| 76 | * man/elem.Rd: Comment out example to avoid R CMD check warnings | |
| 77 | ||
| 78 | 2005-03-22 01:16 warnes | |
| 79 | ||
| 80 | * NAMESPACE, R/ConvertMedUnits.R, data/MedUnits.Rda, | |
| 81 | data/MedUnits.rda, man/ConvertMedUnits.Rd, man/MedUnits.Rd: Fixes | |
| 82 | to pass `R CMD check'. | |
| 83 | ||
| 84 | 2005-03-21 21:51 warnes | |
| 85 | ||
| 86 | * R/Args.R, R/env.R, R/ll.R, man/Args.Rd: Integrated fixes from | |
| 87 | Arni. | |
| 88 | ||
| 89 | 2005-03-21 21:50 warnes | |
| 90 | ||
| 91 | * man/read.xls.Rd: Improve documentation of 'perl' argument and | |
| 92 | give examples. | |
| 93 | ||
| 94 | 2005-03-09 18:39 warnes | |
| 95 | ||
| 96 | * R/ConvertMedUnits.R, man/ConvertMedUnits.Rd, man/MedUnits.Rd: - | |
| 97 | Add ConvertMedUnits() plus documentation - Add documentation for | |
| 98 | MedUnits data set. | |
| 99 | ||
| 100 | 2005-03-09 18:37 warnes | |
| 101 | ||
| 102 | * data/MedUnits.Rda: Update MedUnits data file. | |
| 103 | ||
| 104 | 2005-03-09 17:00 warnes | |
| 105 | ||
| 106 | * data/MedUnits.tab: Don't need both .Rda and .tab forms of the | |
| 107 | data. | |
| 108 | ||
| 109 | 2005-03-09 16:55 warnes | |
| 110 | ||
| 111 | * data/: MedUnits.Rda, MedUnits.tab: Add MedUnits data set, which | |
| 112 | provides conversions between American 'Conventional' and Standard | |
| 113 | Intertional (SI) medical units. | |
| 114 | ||
| 115 | 2005-03-01 12:59 warnes | |
| 116 | ||
| 117 | * man/: elem.Rd, ll.Rd: - Remove 'elem' call from ll example. - | |
| 118 | Add note to 'elem' man page that it is depreciated and 'll' | |
| 119 | should be used instead. | |
| 120 | ||
| 121 | 2005-02-25 20:15 nj7w(Nitin Jain) | |
| 122 | ||
| 123 | * NAMESPACE, man/elem.Rd, man/env.Rd, man/ll.Rd, man/read.xls.Rd: | |
| 124 | [no log message] | |
| 125 | ||
| 126 | 2005-02-25 18:32 warnes | |
| 127 | ||
| 128 | * NAMESPACE: Remove ll methods since the base function now handles | |
| 129 | lists and data frames. | |
| 130 | ||
| 131 | 2005-02-25 18:22 warnes | |
| 132 | ||
| 133 | * R/elem.R, R/env.R, R/ll.R, man/Args.Rd, man/env.Rd, man/ll.Rd: | |
| 134 | Integrate changes submitted by Arni Magnusson | |
| 135 | ||
| 136 | 2005-01-31 17:22 warnes | |
| 137 | ||
| 138 | * R/read.xls.R, man/read.xls.Rd: Add ability to specify the perl | |
| 139 | executable and path. | |
| 140 | ||
| 141 | 2005-01-28 13:58 warnes | |
| 142 | ||
| 143 | * DESCRIPTION.in, NAMESPACE: Add dependency on stats. | |
| 144 | ||
| 145 | 2005-01-12 15:50 warnes | |
| 146 | ||
| 147 | * DESCRIPTION.in: Add dependency on R 1.9.0+ to prevent poeple from | |
| 148 | installing on old versions of R which don't support namespaces. | |
| 149 | ||
| 150 | 2004-12-27 17:09 warnes | |
| 151 | ||
| 152 | * man/unmatrix.Rd: Update usage to match code. | |
| 153 | ||
| 154 | 2004-12-27 17:05 warnes | |
| 155 | ||
| 156 | * R/unmatrix.R: Replace 'F' with 'FALSE'. | |
| 157 | ||
| 158 | 2004-10-12 10:57 warneg | |
| 159 | ||
| 160 | * R/unmatrix.R, man/unmatrix.Rd: Add unmatrix() function | |
| 161 | ||
| 162 | 2004-09-27 17:01 tag rel_2_0_0 | |
| 163 | ||
| 164 | 2004-09-27 17:01 warneg | |
| 165 | ||
| 166 | * DESCRIPTION, DESCRIPTION.in, NAMESPACE, man/.Rhistory: Updated to | |
| 167 | pass R CMD check. | |
| 168 | ||
| 169 | 2004-09-03 19:08 warneg | |
| 170 | ||
| 171 | * inst/xls/iris.xls: added to cvs. | |
| 172 | ||
| 173 | 2004-09-03 18:58 warneg | |
| 174 | ||
| 175 | * inst/perl/xls2csv.pl: Checkin xls2csv.pl. Should have been in | |
| 176 | long ago, must have been an oversight | |
| 177 | ||
| 178 | 2004-09-03 18:46 warneg | |
| 179 | ||
| 180 | * R/read.xls.R: Need to look for files using the new package name. | |
| 181 | ||
| 182 | 2004-09-03 18:43 warneg | |
| 183 | ||
| 184 | * man/read.xls.Rd: Need to use the new package name when looking | |
| 185 | for iris.xls. | |
| 186 | ||
| 187 | 2004-09-03 18:42 warneg | |
| 188 | ||
| 189 | * man/ll.Rd: Add ll.list to the to the list of functions described | |
| 190 | ||
| 191 | 2004-09-03 18:42 warneg | |
| 192 | ||
| 193 | * NAMESPACE: Add ll and friends to the namespace | |
| 194 | ||
| 195 | 2004-09-03 13:27 warneg | |
| 196 | ||
| 197 | * DESCRIPTION, DESCRIPTION.in, NAMESPACE, R/Args.R, | |
| 198 | R/aggregate.table.R, R/combine.R, R/elem.R, R/env.R, | |
| 199 | R/interleave.R, R/is.what.R, R/keep.R, R/ll.R, R/matchcols.R, | |
| 200 | R/nobs.R, R/read.xls.R, R/rename.vars.R, R/reorder.R, R/trim.R, | |
| 201 | man/reorder.Rd: initial bundle checkin | |
| 202 | ||
| 203 | 2004-09-02 13:14 tag initial | |
| 204 | ||
| 205 | 2004-09-02 13:14 warneg | |
| 206 | ||
| 207 | * DESCRIPTION, DESCRIPTION.in, NAMESPACE, man/.Rhistory: Initial | |
| 208 | revision | |
| 209 | ||
| 210 | 2004-09-02 13:14 warneg | |
| 211 | ||
| 212 | * DESCRIPTION, DESCRIPTION.in, NAMESPACE, man/.Rhistory: [no log | |
| 213 | message] | |
| 214 | ||
| 215 | 2004-08-27 17:57 warnes | |
| 216 | ||
| 217 | * R/reorder.R, man/reorder.Rd: Fixed bug in mixedsort, and modified | |
| 218 | reorder.factor to use mixedsort. | |
| 219 | ||
| 220 | 2004-07-29 11:27 warnes | |
| 221 | ||
| 222 | * inst/perl/: IO/AtomicFile.pm, IO/InnerFile.pm, IO/Lines.pm, | |
| 223 | IO/Scalar.pm, IO/Scalar.pm.html, IO/ScalarArray.pm, | |
| 224 | IO/Stringy.pm, IO/Wrap.pm, IO/WrapTie.pm, OLE/Storage_Lite.pm, | |
| 225 | Spreadsheet/ParseExcel.pm, Spreadsheet/ParseExcel/Dump.pm, | |
| 226 | Spreadsheet/ParseExcel/FmtDefault.pm, | |
| 227 | Spreadsheet/ParseExcel/FmtJapan.pm, | |
| 228 | Spreadsheet/ParseExcel/FmtJapan2.pm, | |
| 229 | Spreadsheet/ParseExcel/FmtUnicode.pm, | |
| 230 | Spreadsheet/ParseExcel/SaveParser.pm, | |
| 231 | Spreadsheet/ParseExcel/Utility.pm: Add perl modules to CVS. | |
| 232 | ||
| 233 | 2004-07-27 10:29 warnes | |
| 234 | ||
| 235 | * man/read.xls.Rd: Fix typos/spelling. | |
| 236 | ||
| 237 | 2004-07-27 10:25 warnes | |
| 238 | ||
| 239 | * man/read.xls.Rd: Add note that Perl is required for read.xls to | |
| 240 | work properly. | |
| 241 | ||
| 242 | 2004-07-16 15:28 warnes | |
| 243 | ||
| 244 | * R/read.xls.R: Remove the temporary csv file if reading it in | |
| 245 | fails. | |
| 246 | ||
| 247 | 2004-06-22 13:09 warnes | |
| 248 | ||
| 249 | * R/ll.R, man/ll.Rd: Add S3 methods for data frames and lists. | |
| 250 | ||
| 251 | 2004-06-07 23:54 warnes | |
| 252 | ||
| 253 | * inst/bin/: xls2csv, xls2csv.bat: Moved from gregmisc/src/. | |
| 254 | ||
| 255 | 2004-06-05 01:22 tag rel_1_11_1 | |
| 256 | ||
| 257 | 2004-06-05 01:22 tag rel_1_11_2 | |
| 258 | ||
| 259 | 2004-06-05 01:22 warnes | |
| 260 | ||
| 261 | * man/read.xls.Rd: Minor enhancment to read.xls example. | |
| 262 | ||
| 263 | 2004-06-05 00:05 warnes | |
| 264 | ||
| 265 | * inst/xls/iris.xls: - Merge Makefile.win into Makefile. | |
| 266 | Makefile.win now just redirects to Makefile. - Update | |
| 267 | xls2csv.bat and xls2csv shell script to correctly obtain thier | |
| 268 | installion path and infer the location of the perl code and | |
| 269 | libraries. - The xls2csv.pl script now assumes that the | |
| 270 | libraries it needs are installed into the same directory where | |
| 271 | it is. | |
| 272 | ||
| 273 | 2004-05-27 18:38 warnes | |
| 274 | ||
| 275 | * inst/perl/xls2csv.pl: Moved to xls2csv.pl.in. | |
| 276 | ||
| 277 | 2004-05-27 18:20 tag rel_1_11_0 | |
| 278 | ||
| 279 | 2004-05-27 18:20 warnes | |
| 280 | ||
| 281 | * inst/perl/xls2csv.pl: More fixes. | |
| 282 | ||
| 283 | 2004-05-27 18:20 warnes | |
| 284 | ||
| 285 | * man/elem.Rd: Fix missing brace. | |
| 286 | ||
| 287 | 2004-05-27 17:43 warnes | |
| 288 | ||
| 289 | * man/elem.Rd: | |
| 290 | Add explicit package name to see also links. | |
| 291 | ||
| 292 | 2004-05-27 17:24 warnes | |
| 293 | ||
| 294 | * inst/perl/xls2csv.pl: More xls2csv perl module support changes. | |
| 295 | ||
| 296 | 2004-05-26 09:40 warnes | |
| 297 | ||
| 298 | * man/read.xls.Rd: Escape underscores in email addresses so Latex | |
| 299 | is happy. | |
| 300 | ||
| 301 | 2004-05-25 14:45 warnes | |
| 302 | ||
| 303 | * inst/perl/xls2csv.pl: More changes to xls2csv code. | |
| 304 | ||
| 305 | 2004-05-25 13:35 warnes | |
| 306 | ||
| 307 | * R/Args.R, man/Args.Rd: Add Args() function contributed by Arni | |
| 308 | Magnusson <arnima@u.washington.edu>. | |
| 309 | ||
| 310 | 2004-05-25 13:14 warnes | |
| 311 | ||
| 312 | * R/read.xls.R: | |
| 313 | - Change to call perl directly rather than depending on the | |
| 314 | installed shell script. This should make the code more portable | |
| 315 | to MS-Windows systes. | |
| 316 | ||
| 317 | - Add additional commants.. | |
| 318 | ||
| 319 | 2004-05-25 07:35 warnes | |
| 320 | ||
| 321 | * R/read.xls.R, man/read.xls.Rd: Add read.xls(), a function to read | |
| 322 | Microsoft Excel files by translating them to csv files via the | |
| 323 | xls2csv.pl script. | |
| 324 | ||
| 325 | 2004-05-24 19:46 warnes | |
| 326 | ||
| 327 | * inst/: perl/xls2csv.pl, xls/iris.xls: Add files to enable | |
| 328 | inclusion and installation of xls2csv.pl as part of the package. | |
| 329 | ||
| 330 | 2004-04-01 15:23 tag gregmisc_0_10_2 | |
| 331 | ||
| 332 | 2004-04-01 15:23 warnes | |
| 333 | ||
| 334 | * R/rename.vars.R, man/rename.vars.Rd: Add function remove.vars(). | |
| 335 | ||
| 336 | 2004-03-26 17:31 warnes | |
| 337 | ||
| 338 | * man/reorder.Rd: Contents of package 'mva' moveed to 'stats'. | |
| 339 | ||
| 340 | 2004-03-26 17:02 warnes | |
| 341 | ||
| 342 | * R/is.what.R: - Fix is.what() for use under R 1.9.0 - is.what() | |
| 343 | now uses is.* functions found in any attached frame | |
| 344 | ||
| 345 | 2004-01-21 07:06 tag gregmisc_0_8_9 | |
| 346 | ||
| 347 | 2004-01-21 07:06 tag rel_0_8_8 | |
| 348 | ||
| 349 | 2004-01-21 07:06 warnes | |
| 350 | ||
| 351 | * R/reorder.R, man/reorder.Rd: - Add ... argument to match generic | |
| 352 | provided in mva. | |
| 353 | ||
| 354 | 2004-01-19 17:45 warnes | |
| 355 | ||
| 356 | * R/elem.R, R/env.R, R/ll.R, man/keep.Rd, man/ll.Rd: - Integrated | |
| 357 | (partial) patch submitted by Arni Magnusson to clarify help text. | |
| 358 | - Modifed code to use match.arg(). | |
| 359 | ||
| 360 | 2003-12-15 16:07 warnes | |
| 361 | ||
| 362 | * R/env.R: | |
| 363 | - Applied patch from Arni that fixed a bug that caused env() to | |
| 364 | crash if any environment was completely empty | |
| 365 | ||
| 366 | 2003-12-02 21:46 tag rel_0_8_5 | |
| 367 | ||
| 368 | 2003-12-02 21:46 tag rel_0_8_7 | |
| 369 | ||
| 370 | 2003-12-02 21:46 warnes | |
| 371 | ||
| 372 | * man/: elem.Rd, ll.Rd: - match function argument defaults with | |
| 373 | 'usage' | |
| 374 | ||
| 375 | 2003-12-02 12:00 warnes | |
| 376 | ||
| 377 | * man/ll.Rd: | |
| 378 | Add one argument, to match code. | |
| 379 | ||
| 380 | 2003-12-01 10:56 warnes | |
| 381 | ||
| 382 | * R/: elem.R, env.R, is.what.R, keep.R, ll.R: | |
| 383 | - Apply changes submitted by Arni Magnusson | |
| 384 | ||
| 385 | 2003-11-19 09:54 warnes | |
| 386 | ||
| 387 | * man/: env.Rd, is.what.Rd, keep.Rd, ll.Rd: | |
| 388 | Changes to pass R CMD check. | |
| 389 | ||
| 390 | 2003-11-18 13:45 warnes | |
| 391 | ||
| 392 | * R/: elem.R, env.R, is.what.R, keep.R, ll.R: | |
| 393 | - Convert from MS-Dos to Unix line endings. - Reformat to 80 | |
| 394 | columns. | |
| 395 | ||
| 396 | 2003-11-17 17:09 warnes | |
| 397 | ||
| 398 | * man/elem.Rd: Replace 'T' with 'TRUE' to remove R CMD check error. | |
| 399 | ||
| 400 | 2003-11-17 17:09 warnes | |
| 401 | ||
| 402 | * man/aggregate.table.Rd: Fix syntax error. | |
| 403 | ||
| 404 | 2003-11-10 17:11 warnes | |
| 405 | ||
| 406 | * R/elem.R, R/env.R, R/is.what.R, R/keep.R, R/ll.R, man/elem.Rd, | |
| 407 | man/env.Rd, man/is.what.Rd, man/keep.Rd, man/ll.Rd: | |
| 408 | - Add files contributed by Arni Magnusson | |
| 409 | <arnima@u.washington.edu>. As well as some of my own. | |
| 410 | ||
| 411 | 2003-06-07 13:58 warnes | |
| 412 | ||
| 413 | * man/: aggregate.table.Rd, interleave.Rd: | |
| 414 | - Fixed error in examples. Had sqrt(var(x)/(n-1)) for the | |
| 415 | standard error of the mean instead of sqrt(var(x)/n). | |
| 416 | ||
| 417 | 2003-05-23 14:32 warnes | |
| 418 | ||
| 419 | * R/matchcols.R, man/matchcols.Rd: | |
| 420 | - Fixed typos | |
| 421 | ||
| 422 | 2003-05-23 14:14 warnes | |
| 423 | ||
| 424 | * R/matchcols.R, man/matchcols.Rd: | |
| 425 | - library() backported from 1.7-devel. This version of the | |
| 426 | function adds the "pos=" argument to specify where in the | |
| 427 | search path the library should be placed. | |
| 428 | ||
| 429 | - updated .First.lib to use library(...pos=3) for MASS to avoid | |
| 430 | the 'genotype' data set in MASS from masking the genotype | |
| 431 | funciton in genetics when it loads gregmisc | |
| 432 | ||
| 433 | - Added logit() inv.logit() matchcols() function and | |
| 434 | corresponding docs | |
| 435 | ||
| 436 | 2003-05-20 12:03 warnes | |
| 437 | ||
| 438 | * R/interleave.R: | |
| 439 | - Omit NULL variables. | |
| 440 | ||
| 441 | 2003-05-20 09:16 warnes | |
| 442 | ||
| 443 | * R/trim.R, man/trim.Rd: | |
| 444 | - Added function trim() and assocated docs. | |
| 445 | ||
| 446 | 2003-04-22 11:42 tag rel_0_8_4 | |
| 447 | ||
| 448 | 2003-04-22 11:42 warnes | |
| 449 | ||
| 450 | * R/reorder.R, man/reorder.Rd: | |
| 451 | - The mva package (which is part of recommended) now provides a | |
| 452 | generic 'reorder' function. Consequently, the 'reorder' function | |
| 453 | here has been renamed to 'reorder.factor'. | |
| 454 | ||
| 455 | - Removed check of whether the argument is a factor object. | |
| 456 | ||
| 457 | 2003-03-03 12:48 tag rel_0_8_2 | |
| 458 | ||
| 459 | 2003-03-03 12:48 tag rel_0_8_3 | |
| 460 | ||
| 461 | 2003-03-03 12:48 warnes | |
| 462 | ||
| 463 | * man/reorder.Rd: - Updated to match reorder.Rd which was exetended | |
| 464 | to handle factor label names in addition to numeric indices. | |
| 465 | ||
| 466 | 2003-03-03 12:24 warnes | |
| 467 | ||
| 468 | * R/reorder.R: | |
| 469 | - Added handling of factor level names in addition to numeric | |
| 470 | indexes. | |
| 471 | ||
| 472 | 2002-09-23 10:02 tag rel_0_6_0 | |
| 473 | ||
| 474 | 2002-09-23 10:02 tag rel_0_7_0 | |
| 475 | ||
| 476 | 2002-09-23 10:02 tag rel_0_7_2 | |
| 477 | ||
| 478 | 2002-09-23 10:02 tag rel_0_7_3 | |
| 479 | ||
| 480 | 2002-09-23 10:02 tag rel_0_7_5 | |
| 481 | ||
| 482 | 2002-09-23 10:02 tag rel_0_8_0 | |
| 483 | ||
| 484 | 2002-09-23 10:02 warnes | |
| 485 | ||
| 486 | * inst/doc/: Rnews.dtx, Rnews.sty, gregmisc.pdf, gregmisc.tex: | |
| 487 | Added inst/doc directory and contents to CVS. | |
| 488 | ||
| 489 | 2002-09-23 09:59 warnes | |
| 490 | ||
| 491 | * R/aggregate.table.R, R/combine.R, R/interleave.R, R/nobs.R, | |
| 492 | man/aggregate.table.Rd, man/combine.Rd, man/interleave.Rd, | |
| 493 | man/nobs.Rd, man/rename.vars.Rd, man/reorder.Rd: - Modified all | |
| 494 | files to include CVS Id and Log tags. | |
| 495 | ||
| 496 | 2002-08-01 14:06 tag rel_0_5_4 | |
| 497 | ||
| 498 | 2002-08-01 14:06 tag rel_0_5_5 | |
| 499 | ||
| 500 | 2002-08-01 14:06 warnes | |
| 501 | ||
| 502 | * R/reorder.R: | |
| 503 | Added reorder() function to reorder the levels of a factor. | |
| 504 | ||
| 505 | 2002-04-08 20:51 tag rel_0_5_3 | |
| 506 | ||
| 507 | 2002-04-08 20:51 warneg | |
| 508 | ||
| 509 | * R/rename.vars.R, man/aggregate.table.Rd, man/interleave.Rd, | |
| 510 | man/reorder.Rd: | |
| 511 | Checkin for version 0.5.3 | |
| 512 | ||
| 513 | 2002-04-08 20:46 warneg | |
| 514 | ||
| 515 | * R/interleave.R: - Properly handle case when some or all arguments | |
| 516 | are vectors. | |
| 517 | ||
| 518 | 2002-03-26 16:22 tag rel_0_5_1 | |
| 519 | ||
| 520 | 2002-03-26 16:22 warneg | |
| 521 | ||
| 522 | * man/reorder.Rd: | |
| 523 | - Changed methods to include '...' to match the generic. - | |
| 524 | Updated for version 0.5.1 | |
| 525 | ||
| 526 | 2002-03-26 14:29 warneg | |
| 527 | ||
| 528 | * R/nobs.R: | |
| 529 | Added ... to methods. | |
| 530 | ||
| 531 | 2002-03-26 14:29 warneg | |
| 532 | ||
| 533 | * man/nobs.Rd: | |
| 534 | Updated to add ... parameter to function calls. | |
| 535 | ||
| 536 | 2002-03-26 10:27 warneg | |
| 537 | ||
| 538 | * man/reorder.Rd: | |
| 539 | Initial checkin. | |
| 540 | ||
| 541 | 2002-03-26 09:28 warneg | |
| 542 | ||
| 543 | * R/nobs.R: - Added CVS tags | |
| 544 | ||
| 545 | 2002-02-21 16:45 warneg | |
| 546 | ||
| 547 | * R/aggregate.table.R: | |
| 548 | - Fixed bug where row and column labels didn't always correspond | |
| 549 | to the contents. This only occured when a factor was used for | |
| 550 | by1 or by2 and the factors levels weren't in the default sort | |
| 551 | order. | |
| 552 | ||
| 553 | 2002-02-20 17:10 warneg | |
| 554 | ||
| 555 | * R/aggregate.table.R: | |
| 556 | New function. | |
| 557 | ||
| 558 | 2002-02-20 17:09 warneg | |
| 559 | ||
| 560 | * man/aggregate.table.Rd: | |
| 561 | Initial checkin. | |
| 562 | ||
| 563 | 2002-02-20 16:41 warneg | |
| 564 | ||
| 565 | * man/interleave.Rd, R/interleave.R: Initial checkin. | |
| 566 | ||
| 567 | 2002-02-20 16:31 warneg | |
| 568 | ||
| 569 | * man/nobs.Rd: | |
| 570 | Noted that specialized methods exist. | |
| 571 | ||
| 572 | 2002-02-20 16:29 warneg | |
| 573 | ||
| 574 | * man/nobs.Rd: | |
| 575 | Incorrectly had contents of nobs.R here instead of help text. | |
| 576 | Corrected. | |
| 577 | ||
| 578 | 2002-02-20 15:09 warneg | |
| 579 | ||
| 580 | * man/rename.vars.Rd: | |
| 581 | Minor changes, typo and formatting fixes. | |
| 582 | ||
| 583 | 2002-02-20 15:03 warneg | |
| 584 | ||
| 585 | * R/nobs.R, man/nobs.Rd: - initial checkin. | |
| 586 | ||
| 587 | 2001-12-11 20:39 tag rel_0_5_0 | |
| 588 | ||
| 589 | 2001-12-11 20:39 warneg | |
| 590 | ||
| 591 | * man/rename.vars.Rd: | |
| 592 | Added omitted documentaton for 'info' parameter. Changed example | |
| 593 | code not to use 'Orthodont' data set so that the nlme package is | |
| 594 | not required. | |
| 595 | ||
| 596 | 2001-12-07 20:54 warneg | |
| 597 | ||
| 598 | * R/rename.vars.R: Changed 'T' to 'TRUE' in parameter list. | |
| 599 | ||
| 600 | 2001-12-07 18:33 warneg | |
| 601 | ||
| 602 | * man/rename.vars.Rd: - Fixed see also link. Mis-typed | |
| 603 | 'data.frame' as 'dataframe'. | |
| 604 | ||
| 605 | 2001-12-07 17:55 warneg | |
| 606 | ||
| 607 | * R/rename.vars.R: | |
| 608 | Added attribution. | |
| 609 | ||
| 610 | 2001-12-07 17:49 warneg | |
| 611 | ||
| 612 | * man/rename.vars.Rd: | |
| 613 | Added proper attribution to Don MacQueen. | |
| 614 | ||
| 615 | 2001-12-07 16:48 warneg | |
| 616 | ||
| 617 | * man/rename.vars.Rd: | |
| 618 | Initial checkin. Unfortunately, I've lost the email of the | |
| 619 | person who sent this to me. I'll credit him/her when I find out | |
| 620 | who it was! | |
| 621 | ||
| 622 | 2001-12-07 16:40 warneg | |
| 623 | ||
| 624 | * R/rename.vars.R: | |
| 625 | Initial checkin | |
| 626 | ||
| 627 | 2001-12-05 14:51 warneg | |
| 628 | ||
| 629 | * R/combine.R: | |
| 630 | - Renamed 'concat' function to 'combine' to avoid name conflict | |
| 631 | with an existing S-Plus function. | |
| 632 | ||
| 633 | 2001-12-05 14:44 warneg | |
| 634 | ||
| 635 | * man/combine.Rd: | |
| 636 | - Changed function name 'concat' to 'combine' and renamed | |
| 637 | concat.Rd to combine.Rd | |
| 638 |
| 0 | Package: gdata | |
| 1 | Title: Various R programming tools for data manipulation | |
| 2 | Description: Various R programming tools for data manipulation | |
| 3 | Depends: R (>= 1.9.0) | |
| 4 | Suggests: gtools | |
| 5 | Version: 2.0.8 | |
| 6 | Date: 2005-08-31 | |
| 7 | Author: Gregory R. Warnes. Includes R source code and/or documentation | |
| 8 | contributed by Ben Bolker and Thomas Lumley | |
| 9 | Maintainer: Nitin Jain <nitin.jain@pfizer.com> | |
| 10 | License: GPL (version 2 or later) | |
| 11 | Packaged: Tue Sep 6 11:31:26 2005; jainn02 |
| 0 | ||
| 1 | export( | |
| 2 | Args, | |
| 3 | aggregate.table, | |
| 4 | combine, | |
| 5 | ConvertMedUnits, | |
| 6 | drop.levels, | |
| 7 | elem, | |
| 8 | env, | |
| 9 | frameApply, | |
| 10 | interleave, | |
| 11 | is.what, | |
| 12 | keep, | |
| 13 | ll, | |
| 14 | matchcols, | |
| 15 | nobs, | |
| 16 | read.xls, | |
| 17 | rename.vars, | |
| 18 | remove.vars, | |
| 19 | reorder.factor, | |
| 20 | trim, | |
| 21 | unmatrix | |
| 22 | ) | |
| 23 | ||
| 24 | importFrom(stats, reorder, na.omit) | |
| 25 | ## importFrom(gtools, mixedsort) | |
| 26 | ||
| 27 | S3method(nobs,data.frame) | |
| 28 | S3method(nobs,default) | |
| 29 | S3method(nobs,lm) | |
| 30 | S3method(reorder,factor) | |
| 31 |
| 0 | CHANGES IN GDATA 2.0.8 | |
| 1 | ----------------------- | |
| 2 | ||
| 3 | - Added DESCRIPTION and removed DESCRIPTION.in | |
| 4 | ||
| 5 | - Updated ll.Rd documentation | |
| 6 | ||
| 7 | - Fixed bug in Args.R, is.what.R, ll.R | |
| 8 | ||
| 9 |
| 0 | Args <- function(name, sort.args=FALSE) | |
| 1 | { | |
| 2 | a <- formals(get(as.character(substitute(name)), pos=1)) | |
| 3 | if(is.null(a)) | |
| 4 | return(NULL) | |
| 5 | arg.labels <- names(a) | |
| 6 | arg.values <- as.character(a) | |
| 7 | char <- sapply(a, is.character) | |
| 8 | arg.values[char] <- paste("\"", arg.values[char], "\"", sep="") | |
| 9 | ||
| 10 | if(sort.args) | |
| 11 | { | |
| 12 | ord <- order(arg.labels) | |
| 13 | if(any(arg.labels == "...")) | |
| 14 | ord <- c(ord[-which(arg.labels[ord]=="...")], | |
| 15 | which(arg.labels=="...")) | |
| 16 | arg.labels <- arg.labels[ord] | |
| 17 | arg.values <- arg.values[ord] | |
| 18 | } | |
| 19 | ||
| 20 | output <- data.frame(value=I(arg.values), row.names=arg.labels) | |
| 21 | print(output, right=FALSE) | |
| 22 | ||
| 23 | invisible(output) | |
| 24 | } | |
| 25 |
| 0 | ConvertMedUnits <- function(x, measurement, abbreviation, | |
| 1 | to=c("Conventional","SI","US"), | |
| 2 | exact=!missing(abbreviation)) | |
| 3 | { | |
| 4 | data(MedUnits,package='gdata') | |
| 5 | to=match.arg(to) | |
| 6 | if(!missing(measurement) && missing(abbreviation)) | |
| 7 | { | |
| 8 | if(exact) | |
| 9 | matchUnits <- MedUnits[tolower(MedUnits$Measurement)== | |
| 10 | tolower(measurement),] | |
| 11 | else | |
| 12 | matchUnits <- MedUnits[grep(measurement, MedUnits$Measurement, | |
| 13 | ignore.case=TRUE),] | |
| 14 | } | |
| 15 | else if(missing(measurement) && !missing(abbreviation)) | |
| 16 | { | |
| 17 | if(exact) | |
| 18 | matchUnits <- MedUnits[tolower(MedUnits$Abbreviation)== | |
| 19 | tolower(abbreviation),] | |
| 20 | else | |
| 21 | matchUnits <- MedUnits[grep(match, MedUnits$Abbrevation, | |
| 22 | ignore.case=TRUE),] | |
| 23 | } | |
| 24 | else # both missing or both specified | |
| 25 | stop("One of `measurement' or `abbreviation' must be specified.") | |
| 26 | ||
| 27 | ||
| 28 | if(nrow(matchUnits)>1) | |
| 29 | stop( | |
| 30 | paste("More than one matching row. Please use 'exact=TRUE' ", | |
| 31 | "and supply one of these matching strings:", | |
| 32 | paste('\t"',matchUnits$Measurement, '"', sep='', collapse="\n\t"), | |
| 33 | sep="\n\t")) | |
| 34 | else if (nrow(matchUnits)<1) | |
| 35 | stop("No match") | |
| 36 | ||
| 37 | if (to %in% c("Convetional", "US")) | |
| 38 | { | |
| 39 | retval <- x / matchUnits$Conversion | |
| 40 | attr(retval,"units") <- matchUnits$ConventionalUnits | |
| 41 | } | |
| 42 | else | |
| 43 | { | |
| 44 | retval <- x * matchUnits$Conversion | |
| 45 | attr(retval,"units") <- matchUnits$SIUnits | |
| 46 | } | |
| 47 | retval | |
| 48 | } | |
| 49 | ||
| 50 | ||
| 51 | ||
| 52 | ||
| 53 |
| 0 | # $Id: aggregate.table.R,v 1.5 2005/06/09 14:20:24 nj7w Exp $ | |
| 1 | ||
| 2 | aggregate.table <- function(x, by1, by2, FUN=mean, ... ) | |
| 3 | { | |
| 4 | if(!is.factor(by1)) by1 <- as.factor(by1) | |
| 5 | if(!is.factor(by2)) by2 <- as.factor(by2) | |
| 6 | ||
| 7 | ag <- aggregate(x, by=list(by1,by2), FUN=FUN, ... ) | |
| 8 | tab <- matrix( nrow=nlevels(by1), ncol=nlevels(by2) ) | |
| 9 | dimnames(tab) <- list(levels(by1),levels(by2)) | |
| 10 | ||
| 11 | for(i in 1:nrow(ag)) | |
| 12 | tab[ as.character(ag[i,1]), as.character(ag[i,2]) ] <- ag[i,3] | |
| 13 | tab | |
| 14 | } |
| 0 | # $Id: combine.R,v 1.4 2005/06/09 14:20:24 nj7w Exp $ | |
| 1 | ||
| 2 | combine <- function(..., names=NULL) | |
| 3 | { | |
| 4 | tmp <- list(...) | |
| 5 | if(is.null(names)) names <- names(tmp) | |
| 6 | if(is.null(names)) names <- sapply( as.list(match.call()), deparse)[-1] | |
| 7 | ||
| 8 | if( any( | |
| 9 | sapply(tmp, is.matrix) | |
| 10 | | | |
| 11 | sapply(tmp, is.data.frame) ) ) | |
| 12 | { | |
| 13 | len <- sapply(tmp, function(x) c(dim(x),1)[1] ) | |
| 14 | len[is.null(len)] <- 1 | |
| 15 | data <- rbind( ... ) | |
| 16 | } | |
| 17 | else | |
| 18 | { | |
| 19 | len <- sapply(tmp,length) | |
| 20 | data <- unlist(tmp) | |
| 21 | ||
| 22 | } | |
| 23 | ||
| 24 | namelist <- factor(rep(names, len), levels=names) | |
| 25 | ||
| 26 | return( data.frame( data, source=namelist) ) | |
| 27 | } |
| 0 | drop.levels <- function(x, reorder = TRUE, ...) { | |
| 1 | as.data.frame(lapply(x, function(xi) { | |
| 2 | if(is.factor(xi)) { | |
| 3 | xi <- factor(xi) | |
| 4 | if(reorder) | |
| 5 | xi <- reorder(xi, ...) | |
| 6 | } | |
| 7 | xi | |
| 8 | })) | |
| 9 | } |
| 0 | # $Id: elem.R,v 1.7 2005/06/09 14:20:24 nj7w Exp $ | |
| 1 | ||
| 2 | elem <- function(object=1, unit=c("KB","MB","bytes"), digits=0, | |
| 3 | dimensions=FALSE) | |
| 4 | { | |
| 5 | .Deprecated("ll", package="gdata") | |
| 6 | ll(pos=object, unit=unit, digits=digits, dimensions=dimensions) | |
| 7 | } | |
| 8 |
| 0 | # $Id: env.R,v 1.9 2005/06/09 14:20:24 nj7w Exp $ | |
| 1 | ||
| 2 | env <- function(unit=c("KB","MB","bytes"), digits=0) | |
| 3 | { | |
| 4 | get.object.size <- function(object.name, pos) | |
| 5 | { | |
| 6 | object <- get(object.name, pos=pos) | |
| 7 | size <- try(object.size(object), silent=TRUE) | |
| 8 | if(class(size) == "try-error") | |
| 9 | size <- 0 | |
| 10 | return(size) | |
| 11 | } | |
| 12 | ||
| 13 | get.environment.size <- function(pos) | |
| 14 | { | |
| 15 | if(search()[pos]=="Autoloads" || length(ls(pos,all=TRUE))==0) | |
| 16 | size <- 0 | |
| 17 | else | |
| 18 | size <- sum(sapply(ls(pos,all=TRUE), get.object.size, pos=pos)) | |
| 19 | return(size) | |
| 20 | } | |
| 21 | ||
| 22 | get.environment.nobjects <- function(pos) | |
| 23 | { | |
| 24 | nobjects <- length(ls(pos,all=TRUE)) | |
| 25 | return(nobjects) | |
| 26 | } | |
| 27 | ||
| 28 | unit <- match.arg(unit) | |
| 29 | denominator <- switch(unit, "KB"=1024, "MB"=1024^2, 1) | |
| 30 | size.vector <- sapply(seq(along=search()), get.environment.size) | |
| 31 | size.vector <- round(size.vector/denominator, digits) | |
| 32 | nobjects.vector <- sapply(seq(along=search()), get.environment.nobjects) | |
| 33 | env.frame <- data.frame(search(), nobjects.vector, size.vector) | |
| 34 | names(env.frame) <- c("Environment", "Objects", unit) | |
| 35 | ||
| 36 | print(env.frame, right=FALSE) | |
| 37 | invisible(env.frame) | |
| 38 | } | |
| 39 |
| 0 | # $Id: frameApply.R,v 1.2 2005/06/09 14:20:24 nj7w Exp $ | |
| 1 | # | |
| 2 | frameApply <- function(x, by = NULL, on = by[1], fun = function(xi) c(Count = nrow(xi)) , subset = TRUE, simplify = TRUE, byvar.sep = "\\$\\@\\$", ...) { | |
| 3 | subset <- eval(substitute(subset), x, parent.frame()) | |
| 4 | x <- x[subset, , drop = FALSE] | |
| 5 | if(!is.null(by)) { | |
| 6 | x[by] <- drop.levels(x[by]) | |
| 7 | for(i in seq(along = by)) | |
| 8 | if(length(grep(byvar.sep, as.character(x[[by[i]]])))) stop("Choose a different value for byvar.sep.") | |
| 9 | byvars <- unique(x[by]) | |
| 10 | BYVAR <- do.call("paste", c(as.list(x[by]), sep = byvar.sep)) | |
| 11 | byvars <- byvars[order(unique(BYVAR)), , drop = FALSE] | |
| 12 | splx <- split(x[on], BYVAR) | |
| 13 | splres <- lapply(splx, fun, ...) | |
| 14 | if(!simplify) out <- list(by = byvars, result = splres) | |
| 15 | else { | |
| 16 | i <- 1 ; nres <- length(splres) | |
| 17 | while(inherits(splres[[i]], "try-error") & i < nres) i <- i + 1 | |
| 18 | nms <- names(splres[[i]]) | |
| 19 | # nms <- lapply(splres, function(xi) { | |
| 20 | # if(inherits(xi, "try-error")) return(NULL) | |
| 21 | # else names(xi) | |
| 22 | # }) | |
| 23 | # nms <- do.call("rbind", nms)[1, ] | |
| 24 | splres <- lapply(splres, function(xi) { | |
| 25 | if(inherits(xi, "try-error")) { | |
| 26 | return(rep(NA, length(nms))) | |
| 27 | } | |
| 28 | else xi | |
| 29 | }) | |
| 30 | res <- do.call("rbind", splres) | |
| 31 | res <- as.data.frame(res) | |
| 32 | names(res) <- nms | |
| 33 | if(length(intersect(names(byvars), names(res)))) | |
| 34 | stop("Names of \"by\" variables are also used as names of result elements. Not allowed.\n") | |
| 35 | out <- data.frame(byvars, res) | |
| 36 | } | |
| 37 | } | |
| 38 | else { | |
| 39 | out <- fun(x[on]) | |
| 40 | if(simplify) out <- as.data.frame(as.list(out)) | |
| 41 | } | |
| 42 | out | |
| 43 | } |
| 0 | # $Id: interleave.R,v 1.6 2005/06/09 14:20:24 nj7w Exp $ | |
| 1 | ||
| 2 | interleave <- function(..., append.source=TRUE, sep=": ") | |
| 3 | { | |
| 4 | sources <- list(...) | |
| 5 | ||
| 6 | sources[sapply(sources, is.null)] <- NULL | |
| 7 | ||
| 8 | sources <- lapply(sources, function(x) | |
| 9 | if(is.matrix(x) || is.data.frame(x)) | |
| 10 | x else t(x) ) | |
| 11 | ||
| 12 | nrows <- sapply( sources, nrow ) | |
| 13 | mrows <- max(nrows) | |
| 14 | if(any(nrows!=mrows & nrows!=1 )) | |
| 15 | stop("Arguments have differening numbers of rows.") | |
| 16 | ||
| 17 | sources <- lapply(sources, function(x) | |
| 18 | if(nrow(x)==1) x[rep(1,mrows),] else x ) | |
| 19 | ||
| 20 | tmp <- do.call("rbind",sources) | |
| 21 | ||
| 22 | nsources <- length(sources) | |
| 23 | indexes <- outer( ( 0:(nsources-1) ) * mrows , 1:mrows, "+" ) | |
| 24 | ||
| 25 | retval <- tmp[indexes,] | |
| 26 | ||
| 27 | if(append.source && !is.null(names(sources) )) | |
| 28 | if(!is.null(row.names(tmp)) ) | |
| 29 | row.names(retval) <- paste(format(row.names(retval)), | |
| 30 | format(names(sources)), | |
| 31 | sep=sep) | |
| 32 | else | |
| 33 | row.names(retval) <- rep(names(sources), mrows) | |
| 34 | ||
| 35 | retval | |
| 36 | } |
| 0 | is.what <- function(object, verbose=FALSE) | |
| 1 | { | |
| 2 | do.test <- function(test, object) | |
| 3 | { | |
| 4 | result <- all(get(test)(object)) | |
| 5 | return(result) | |
| 6 | } | |
| 7 | ||
| 8 | ## Get all names starting with "is." | |
| 9 | is.names <- unlist(sapply(search(), function(name) ls(name,pattern="^is\\."))) | |
| 10 | ||
| 11 | ## Narrow to functions | |
| 12 | is.functions <- is.names[sapply(is.names, function(x) is.function(get(x)))] | |
| 13 | ||
| 14 | not.using <- c("is.element", "is.empty.model", "is.loaded", "is.mts", | |
| 15 | "is.na.data.frame", "is.na.POSIXlt", "is.na<-", | |
| 16 | "is.na<-.default", "is.na<-.factor", "is.pairlist", "is.qr", | |
| 17 | "is.R", "is.single", "is.unsorted", "is.what") | |
| 18 | tests <- is.functions[!(is.functions %in% not.using)] | |
| 19 | names(tests) <- NULL | |
| 20 | old.warn <- options(warn=-1) | |
| 21 | results <- sapply(tests, do.test, object=object) | |
| 22 | options(old.warn) | |
| 23 | names(results) <- tests | |
| 24 | ||
| 25 | if(!verbose) | |
| 26 | { | |
| 27 | output <- tests[results==TRUE & !is.na(results)] | |
| 28 | } | |
| 29 | else | |
| 30 | { | |
| 31 | results[results==TRUE] <- "T" | |
| 32 | results[results==FALSE] <- "." | |
| 33 | output <- data.frame(is=I(results)) | |
| 34 | } | |
| 35 | ||
| 36 | return(output) | |
| 37 | } | |
| 38 |
| 0 | # $Id: keep.R,v 1.5 2005/06/09 14:20:24 nj7w Exp $ | |
| 1 | ||
| 2 | keep <- function(..., list=character(0), sure=FALSE) | |
| 3 | { | |
| 4 | if(missing(...) && missing(list)) | |
| 5 | stop("Keep something, or use rm(list=ls()) to clear workspace.") | |
| 6 | names <- as.character(substitute(list(...)))[-1] | |
| 7 | list <- c(list, names) | |
| 8 | keep.elements <- match(list, ls(1)) | |
| 9 | ||
| 10 | if(sure == FALSE) | |
| 11 | return(ls(1)[-keep.elements]) | |
| 12 | else | |
| 13 | rm(list=ls(1)[-keep.elements], pos=1) | |
| 14 | } | |
| 15 |
| 0 | ll <- function(pos=1, unit=c("KB","MB","bytes"), digits=0, dimensions=FALSE, | |
| 1 | function.dim="", sort.elements=FALSE, ...) | |
| 2 | { | |
| 3 | get.object.classname <- function(object.name, pos) | |
| 4 | { | |
| 5 | object <- get(object.name, pos=pos) | |
| 6 | classname <- class(object)[1] | |
| 7 | return(classname) | |
| 8 | } | |
| 9 | ||
| 10 | get.object.dimensions <- function(object.name, pos) | |
| 11 | { | |
| 12 | object <- get(object.name, pos=pos) | |
| 13 | if(class(object)[1] == "function") | |
| 14 | dimensions <- function.dim | |
| 15 | else if(!is.null(dim(object))) | |
| 16 | dimensions <- paste(dim(object), collapse=" x ") | |
| 17 | else | |
| 18 | dimensions <- length(object) | |
| 19 | return(dimensions) | |
| 20 | } | |
| 21 | ||
| 22 | get.object.size <- function(object.name, pos) | |
| 23 | { | |
| 24 | object <- get(object.name, pos=pos) | |
| 25 | size <- try(object.size(object), silent=TRUE) | |
| 26 | if(class(size) == "try-error") | |
| 27 | size <- 0 | |
| 28 | return(size) | |
| 29 | } | |
| 30 | ||
| 31 | unit <- match.arg(unit) | |
| 32 | denominator <- switch(unit, "KB"=1024, "MB"=1024^2, 1) | |
| 33 | ||
| 34 | if(is.character(pos)) # pos is an environment name | |
| 35 | pos <- match(pos, search()) | |
| 36 | if(is.list(pos)) # pos is a list-like object | |
| 37 | { | |
| 38 | if(length(pos) == 0) | |
| 39 | return(data.frame()) | |
| 40 | attach(pos, pos=2) | |
| 41 | original.rank <- rank(names(pos)) | |
| 42 | was.list <- TRUE | |
| 43 | pos <- 2 | |
| 44 | } | |
| 45 | else | |
| 46 | { | |
| 47 | was.list <- FALSE | |
| 48 | } | |
| 49 | if(length(ls(pos,...)) == 0) # pos is an empty environment | |
| 50 | { | |
| 51 | object.frame <- data.frame() | |
| 52 | } | |
| 53 | else if(search()[pos] == "Autoloads") # pos is the autoload environment | |
| 54 | { | |
| 55 | object.frame <- data.frame(rep("function",length(ls(pos,...))), | |
| 56 | rep(0,length(ls(pos,...))), row.names=ls(pos,...)) | |
| 57 | if(dimensions) | |
| 58 | { | |
| 59 | object.frame <- cbind(object.frame, rep(function.dim,nrow(object.frame))) | |
| 60 | names(object.frame) <- c("Class", unit, "Dimensions") | |
| 61 | } | |
| 62 | else | |
| 63 | names(object.frame) <- c("Class", unit) | |
| 64 | } | |
| 65 | else | |
| 66 | { | |
| 67 | class.vector <- sapply(ls(pos,...), get.object.classname, pos=pos) | |
| 68 | size.vector <- sapply(ls(pos,...), get.object.size, pos=pos) | |
| 69 | size.vector <- round(size.vector/denominator, digits) | |
| 70 | object.frame <- data.frame(class.vector=class.vector, | |
| 71 | size.vector=size.vector, row.names=names(size.vector)) | |
| 72 | names(object.frame) <- c("Class", unit) | |
| 73 | if(dimensions) | |
| 74 | object.frame <- cbind(object.frame, Dim=sapply(ls(pos,...), | |
| 75 | get.object.dimensions, pos=pos)) | |
| 76 | } | |
| 77 | if(was.list) | |
| 78 | { | |
| 79 | detach(pos=2) | |
| 80 | if(!sort.elements) | |
| 81 | object.frame <- object.frame[original.rank, ] | |
| 82 | } | |
| 83 | ||
| 84 | return(object.frame) | |
| 85 | } | |
| 86 |
| 0 | # $Id: matchcols.R,v 1.4 2005/06/09 14:20:24 nj7w Exp $ | |
| 1 | # select the columns which match/don't match a set of include/omit patterns. | |
| 2 | ||
| 3 | matchcols <- function(object, with, without, method=c("and","or"), ...) | |
| 4 | { | |
| 5 | method <- match.arg(method) | |
| 6 | cols <- colnames(object) | |
| 7 | ||
| 8 | # include columns matching 'with' pattern(s) | |
| 9 | if(method=="and") | |
| 10 | for(i in 1:length(with)) | |
| 11 | { | |
| 12 | if(length(cols)>0) | |
| 13 | cols <- grep(with[i], cols, value=TRUE, ...) | |
| 14 | } | |
| 15 | else | |
| 16 | if(!missing(with)) | |
| 17 | if(length(cols)>0) | |
| 18 | cols <- sapply( with, grep, x=cols, value=TRUE, ...) | |
| 19 | ||
| 20 | # exclude columns matching 'without' pattern(s) | |
| 21 | if(!missing(without)) | |
| 22 | for(i in 1:length(without)) | |
| 23 | if(length(cols)>0) | |
| 24 | { | |
| 25 | omit <- grep(without[i], cols, ...) | |
| 26 | if(length(omit)>0) | |
| 27 | cols <- cols[-omit] | |
| 28 | } | |
| 29 | ||
| 30 | cols | |
| 31 | } |
| 0 | # $Id: nobs.R,v 1.6 2005/06/09 14:20:24 nj7w Exp $ | |
| 1 | ||
| 2 | nobs <- function(x,...) | |
| 3 | UseMethod("nobs",x) | |
| 4 | ||
| 5 | nobs.default <- function(x, ...) sum( !is.na(x) ) | |
| 6 | ||
| 7 | nobs.data.frame <- function(x, ...) | |
| 8 | sapply(x, nobs.default) | |
| 9 | ||
| 10 | nobs.lm <- function(x, ...) | |
| 11 | nobs.default(x$residuals) |
| 0 | # $Id: read.xls.R,v 1.8 2005/06/09 14:20:24 nj7w Exp $ | |
| 1 | ||
| 2 | read.xls <- function(xls, sheet = 1, verbose=FALSE, ..., perl="perl") | |
| 3 | { | |
| 4 | ||
| 5 | # Creating a temporary function to quote the string | |
| 6 | dQuote.ascii <- function(x) paste('"',x,'"',sep='') | |
| 7 | ||
| 8 | ### | |
| 9 | # directories | |
| 10 | package.dir <- .path.package('gdata') | |
| 11 | perl.dir <- file.path(package.dir,'perl') | |
| 12 | # | |
| 13 | ### | |
| 14 | ||
| 15 | ### | |
| 16 | # files | |
| 17 | ||
| 18 | xls <- dQuote.ascii(xls) # dQuote.ascii in case of spaces in path | |
| 19 | xls2csv <- file.path(perl.dir,'xls2csv.pl') | |
| 20 | csv <- paste(tempfile(), "csv", sep = ".") | |
| 21 | # | |
| 22 | ### | |
| 23 | ||
| 24 | ### | |
| 25 | # execution command | |
| 26 | cmd <- paste(perl, xls2csv, xls, dQuote.ascii(csv), sheet, sep=" ") | |
| 27 | # | |
| 28 | ### | |
| 29 | ||
| 30 | ### | |
| 31 | # do the translation | |
| 32 | if(verbose) cat("Executing ", cmd, "... \n") | |
| 33 | # | |
| 34 | results <- system(cmd, intern=!verbose) | |
| 35 | # | |
| 36 | if (verbose) cat("done.\n") | |
| 37 | # | |
| 38 | ### | |
| 39 | ||
| 40 | # prepare for cleanup now, in case of error reading file | |
| 41 | on.exit(file.remove(csv)) | |
| 42 | ||
| 43 | # now read the csv file | |
| 44 | out <- read.csv(csv, ...) | |
| 45 | ||
| 46 | # clean up | |
| 47 | file.remove(csv) | |
| 48 | ||
| 49 | return(out) | |
| 50 | } |
| 0 | # $Id: rename.vars.R,v 1.7 2005/06/09 14:20:24 nj7w Exp $ | |
| 1 | ||
| 2 | rename.vars <- function(data,from='',to='',info=TRUE) { | |
| 3 | ||
| 4 | dsn <- deparse(substitute(data)) | |
| 5 | dfn <- names(data) | |
| 6 | ||
| 7 | if ( length(from) != length(to)) { | |
| 8 | cat('--------- from and to not same length ---------\n') | |
| 9 | stop() | |
| 10 | } | |
| 11 | ||
| 12 | if (length(dfn) < length(to)) { | |
| 13 | cat('--------- too many new names ---------\n') | |
| 14 | stop() | |
| 15 | } | |
| 16 | ||
| 17 | chng <- match(from,dfn) | |
| 18 | ||
| 19 | frm.in <- from %in% dfn | |
| 20 | if (!all(frm.in) ) { | |
| 21 | cat('---------- some of the from names not found in',dsn,'\n') | |
| 22 | stop() | |
| 23 | } | |
| 24 | ||
| 25 | if (length(to) != length(unique(to))) { | |
| 26 | cat('---------- New names not unique\n') | |
| 27 | stop() | |
| 28 | } | |
| 29 | ||
| 30 | dfn.new <- dfn | |
| 31 | dfn.new[chng] <- to | |
| 32 | if (info) cat('\nChanging in',dsn) | |
| 33 | tmp <- rbind(from,to) | |
| 34 | dimnames(tmp)[[1]] <- c('From:','To:') | |
| 35 | dimnames(tmp)[[2]] <- rep('',length(from)) | |
| 36 | if (info) | |
| 37 | { | |
| 38 | print(tmp,quote=FALSE) | |
| 39 | cat("\n") | |
| 40 | } | |
| 41 | names(data) <- dfn.new | |
| 42 | data | |
| 43 | } | |
| 44 | ||
| 45 | ||
| 46 | # GRW 2004-04-01 | |
| 47 | remove.vars <- function( data, names, info=TRUE) | |
| 48 | { | |
| 49 | for( i in names ) | |
| 50 | { | |
| 51 | if(info) | |
| 52 | cat("Removing variable '", i, "'\n", sep="") | |
| 53 | data[[i]] <- NULL | |
| 54 | } | |
| 55 | data | |
| 56 | } |
| 0 | # $Id: reorder.R,v 1.7 2005/06/09 14:20:24 nj7w Exp $ | |
| 1 | ||
| 2 | # Reorder the levels of a factor. | |
| 3 | ||
| 4 | reorder.factor <- function(x, | |
| 5 | order, | |
| 6 | X, | |
| 7 | FUN, | |
| 8 | sort=mixedsort, | |
| 9 | make.ordered = is.ordered(x), | |
| 10 | ... ) | |
| 11 | { | |
| 12 | constructor <- if (make.ordered) ordered else factor | |
| 13 | ||
| 14 | if (!missing(order)) | |
| 15 | { | |
| 16 | if (is.numeric(order)) | |
| 17 | order = levels(x)[order] | |
| 18 | else | |
| 19 | order = order | |
| 20 | } | |
| 21 | else if (!missing(FUN)) | |
| 22 | order = names(sort(tapply(X, x, FUN, ...))) | |
| 23 | else | |
| 24 | order = sort(levels(x)) | |
| 25 | ||
| 26 | constructor( x, levels=order) | |
| 27 | ||
| 28 | } | |
| 29 | ||
| 30 | ||
| 31 | ||
| 32 |
| 0 | # $Id: trim.R,v 1.3 2005/06/09 14:20:24 nj7w Exp $ | |
| 1 | ||
| 2 | trim <- function(s) | |
| 3 | { | |
| 4 | s <- sub("^ +","",s) | |
| 5 | s <- sub(" +$","",s) | |
| 6 | s | |
| 7 | } |
| 0 | # $Id: unmatrix.R,v 1.3 2005/06/09 14:20:24 nj7w Exp $ | |
| 1 | ||
| 2 | unmatrix <- function(x, byrow=FALSE) | |
| 3 | { | |
| 4 | rnames <- rownames(x) | |
| 5 | cnames <- colnames(x) | |
| 6 | if(is.null(rnames)) rnames <- paste("r",1:nrow(x),sep='') | |
| 7 | if(is.null(cnames)) cnames <- paste("c",1:ncol(x),sep='') | |
| 8 | nmat <- outer( rnames, cnames, paste, sep=":" ) | |
| 9 | ||
| 10 | if(byrow) | |
| 11 | { | |
| 12 | vlist <- c(t(x)) | |
| 13 | names(vlist) <- c(t(nmat)) | |
| 14 | } | |
| 15 | else | |
| 16 | { | |
| 17 | vlist <- c(x) | |
| 18 | names(vlist) <- c(nmat) | |
| 19 | } | |
| 20 | ||
| 21 | return(vlist) | |
| 22 | } |
Binary diff not shown
| 0 | #!/bin/env perl | |
| 1 | ||
| 2 | BEGIN { | |
| 3 | use File::Basename; | |
| 4 | unshift(@INC, dirname $0); | |
| 5 | } | |
| 6 | ||
| 7 | use strict; | |
| 8 | use Spreadsheet::ParseExcel; | |
| 9 | ||
| 10 | # declare some varibles local | |
| 11 | my($row, $col, $sheet, $cell, $usage, $basename, $sheetnumber, $filename); | |
| 12 | ||
| 13 | ## | |
| 14 | ## Usage information | |
| 15 | ## | |
| 16 | $usage = <<EOF; | |
| 17 | ||
| 18 | xls2csv.pl <excel file> [<output file>] [<worksheet number>] | |
| 19 | ||
| 20 | Translate the Microsoft Excel spreadsheet file contained in | |
| 21 | <excel file> into comma separated value format (CSV) and store | |
| 22 | in <output file>. | |
| 23 | ||
| 24 | If <output file> is not specified, the output file will have the | |
| 25 | same name as the input file with '.xls' or '.XLS' (if any) | |
| 26 | removed and '.csv' appended. | |
| 27 | ||
| 28 | If no worksheet number is given, each worksheet will be written to | |
| 29 | a separate file with the name '<output file>_<worksheet name>.csv'. | |
| 30 | ||
| 31 | EOF | |
| 32 | ||
| 33 | ## | |
| 34 | ## parse arguments | |
| 35 | ## | |
| 36 | ||
| 37 | if(!defined($ARGV[0])) | |
| 38 | { | |
| 39 | print $usage; | |
| 40 | exit 1; | |
| 41 | } | |
| 42 | ||
| 43 | $basename = $ARGV[1]; | |
| 44 | $basename =~ s/.csv//; | |
| 45 | if ($basename eq "") | |
| 46 | { | |
| 47 | my @path; | |
| 48 | @path = split(/[\/\\]/, $ARGV[0]); # split on file separator | |
| 49 | $basename = $path[$#path]; | |
| 50 | $basename =~ s/.xls//i; | |
| 51 | } | |
| 52 | ||
| 53 | if(defined($ARGV[2]) ) | |
| 54 | { | |
| 55 | $sheetnumber = $ARGV[2]; | |
| 56 | die "Sheetnumber must be an integer larger than 0." if $sheetnumber < 1; | |
| 57 | } | |
| 58 | ||
| 59 | ## | |
| 60 | ## open spreadsheet | |
| 61 | ## | |
| 62 | ||
| 63 | my $oExcel = new Spreadsheet::ParseExcel; | |
| 64 | ||
| 65 | print "Loading $ARGV[0] ...\n"; | |
| 66 | ||
| 67 | open(FH, "<$ARGV[0]") or die "Unable to open file '$ARGV[0]'.\n"; | |
| 68 | close(FH); | |
| 69 | ||
| 70 | my $oBook = $oExcel->Parse($ARGV[0]); | |
| 71 | ||
| 72 | print "\n"; | |
| 73 | print "Orignal Filename :", $oBook->{File} , "\n"; | |
| 74 | print "Number of Sheets :", $oBook->{SheetCount} , "\n"; | |
| 75 | print "Author :", $oBook->{Author} , "\n"; | |
| 76 | print "\n"; | |
| 77 | ||
| 78 | my @sheetlist = (@{$oBook->{Worksheet}}); | |
| 79 | if (defined($sheetnumber)) | |
| 80 | { | |
| 81 | @sheetlist=($sheetlist[$sheetnumber-1]); | |
| 82 | } | |
| 83 | ||
| 84 | ## | |
| 85 | ## iterate across each worksheet, writing out a separat csv file | |
| 86 | ## | |
| 87 | ||
| 88 | my $i=0; | |
| 89 | foreach my $sheet (@sheetlist) | |
| 90 | { | |
| 91 | $i++; | |
| 92 | ||
| 93 | my $sheetname = $sheet->{Name}; | |
| 94 | if(defined($sheetnumber)) | |
| 95 | { | |
| 96 | $filename = "${basename}.csv"; | |
| 97 | } | |
| 98 | else | |
| 99 | { | |
| 100 | $filename = "${basename}_${sheetname}.csv"; | |
| 101 | } | |
| 102 | ||
| 103 | print "Writing Sheet number $i ('$sheetname') to file '$filename'\n"; | |
| 104 | ||
| 105 | open(OutFile,">$filename"); | |
| 106 | ||
| 107 | my $cumulativeBlankLines=0; | |
| 108 | ||
| 109 | my $minrow = $sheet->{MinRow}; | |
| 110 | my $maxrow = $sheet->{MaxRow}; | |
| 111 | my $mincol = $sheet->{MinCol}; | |
| 112 | my $maxcol = $sheet->{MaxCol}; | |
| 113 | ||
| 114 | print "Minrow=$minrow Maxrow=$maxrow Mincol=$mincol Maxcol=$maxcol\n"; | |
| 115 | ||
| 116 | for(my $row = $minrow; $row <= $maxrow; $row++) | |
| 117 | { | |
| 118 | my $outputLine = ""; | |
| 119 | ||
| 120 | for(my $col = $mincol; $col <= $maxcol; $col++) | |
| 121 | { | |
| 122 | my $cell = $sheet->{Cells}[$row][$col]; | |
| 123 | if( defined($cell) ) | |
| 124 | { | |
| 125 | $_=$cell->Value; #{Val}; | |
| 126 | ||
| 127 | # convert '#NUM!' strings to missing (empty) values | |
| 128 | s/#NUM!//; | |
| 129 | ||
| 130 | # escape double-quote characters in the data since | |
| 131 | # they are used as field delimiters | |
| 132 | s/\"/\\\"/g; | |
| 133 | } | |
| 134 | else | |
| 135 | { | |
| 136 | $_ = ''; | |
| 137 | } | |
| 138 | ||
| 139 | $outputLine .= "\"" . $_ . "\"" if(length($_)>0); | |
| 140 | ||
| 141 | # separate cells with commas | |
| 142 | $outputLine .= "," if( $col != $maxcol) ; | |
| 143 | ||
| 144 | } | |
| 145 | ||
| 146 | #$outputLine =~ s/[, ]+$//g; ## strip off trailing blanks and commas | |
| 147 | ||
| 148 | # skip blank/empty lines | |
| 149 | if( $outputLine =~ /^[, ]*$/ ) | |
| 150 | { | |
| 151 | $cumulativeBlankLines++ | |
| 152 | } | |
| 153 | else | |
| 154 | { | |
| 155 | print OutFile "$outputLine \n" | |
| 156 | } | |
| 157 | } | |
| 158 | ||
| 159 | close OutFile; | |
| 160 | ||
| 161 | print " (Ignored $cumulativeBlankLines blank lines.)\n" | |
| 162 | if ($cumulativeBlankLines); | |
| 163 | print "\n"; | |
| 164 | } | |
| 165 | ||
| 166 | ||
| 167 |
| 0 | \def\fileversion{v0.3.1} | |
| 1 | \def\filename{Rnews} | |
| 2 | \def\filedate{2001/09/04} | |
| 3 | \def\docdate {2001/09/04} | |
| 4 | % | |
| 5 | % \iffalse | |
| 6 | % | |
| 7 | %% | |
| 8 | %% Package `Rnews' to use with LaTeX2e | |
| 9 | %% Copyright (C) 2001 by the R Core Development Team | |
| 10 | %% Please report errors to KH or FL | |
| 11 | %% | |
| 12 | %% -*- LaTeX -*- | |
| 13 | % | |
| 14 | % \fi | |
| 15 | % | |
| 16 | % \iffalse | |
| 17 | % \changes{v0.1}{2001/01/05}{First draft.} | |
| 18 | % \changes{v0.2}{2001/07/01} | |
| 19 | % {Added macros \cmd\P, \cmd\E, \cmd\VAR, \cmd\COV, \cmd\COR, and | |
| 20 | % \cmd\operatorname. Require \pkg{amsfonts} to produce symbols for | |
| 21 | % sets of positive integers etc.} | |
| 22 | % \changes{v0.3}{2001/08/02} | |
| 23 | % {Add package option `driver' for typesetting the driver. | |
| 24 | % Change article environment to use chapters. | |
| 25 | % Ensure unique figure labels.} | |
| 26 | % \changes{v0.3.1}{2001/09/04} | |
| 27 | % {Remove redefinition of |\caption|, which had figures hard-wired. | |
| 28 | % Instead, have our |figure| environment set |\@captype|.} | |
| 29 | % \fi | |
| 30 | % | |
| 31 | % \MakeShortVerb{\|} | |
| 32 | % | |
| 33 | % \newcommand{\AmS}{$${\protect\the\textfont2 A}\kern-.1667em\lower | |
| 34 | % .5ex\hbox{\protect\the\textfont2 M}\kern | |
| 35 | % -.125em{\protect\the\textfont2 S}} | |
| 36 | % \newcommand{\AmSLaTeX}{\mbox{\AmS-\LaTeX}} | |
| 37 | % | |
| 38 | % \title{The package \pkg{\filename}} | |
| 39 | % \author{Kurt Hornik \and Friedrich Leisch} | |
| 40 | % | |
| 41 | % \maketitle | |
| 42 | % | |
| 43 | % \section{Introduction} | |
| 44 | % | |
| 45 | % The \LaTeXe{} package \pkg{\filename} provides commands for formatting | |
| 46 | % the R Newsletter. | |
| 47 | % | |
| 48 | % \section{Documentation} | |
| 49 | % | |
| 50 | % \subsection{Marking Words and Phrases} | |
| 51 | % | |
| 52 | % The \pkg{Rnews} package provides roughly the same commands for marking | |
| 53 | % words and phrases as does Texinfo (but note that the \LaTeX special | |
| 54 | % characters still need special treatment). These commands are | |
| 55 | % \begin{description} | |
| 56 | % \item[\code{\cmd{\code}\{\var{sample-code}\}}] | |
| 57 | % Indicate text that is a literal example of a piece of a program. | |
| 58 | % \item[\code{\cmd{\kbd}\{\var{keyboard-characters}\}}] | |
| 59 | % Indicate keyboard input. | |
| 60 | % \item[\code{\cmd{\key}\{\var{key-name}\}}] | |
| 61 | % Indicate the conventional name for a key on a keyboard. | |
| 62 | % \item[\code{\cmd{\samp}\{\var{text}\}}] | |
| 63 | % Indicate text that is a literal example of a sequence of | |
| 64 | % characters. | |
| 65 | % \item[\code{\cmd{\var}\{\var{metasyntactic-variable}\}}] | |
| 66 | % Indicate a metasyntactic variable. | |
| 67 | % \item[\code{\cmd{\env}\{\var{environment-variable}\}}] | |
| 68 | % Indicate an environment variable. | |
| 69 | % \item[\code{\cmd{\file}\{\var{file-name}\}}] | |
| 70 | % Indicate the name of a file. | |
| 71 | % \item[\code{\cmd{\command}\{\var{command-name}\}}] | |
| 72 | % Indicate a command name (such as \samp{ls}). | |
| 73 | % \item[\code{\cmd{\option}\{\var{option-name}\}}] | |
| 74 | % Indicate a command line option. | |
| 75 | % \item[\code{\cmd{\dfn}\{\var{term}\}}] | |
| 76 | % Indicate the introductory or defining use of a term. | |
| 77 | % \item[\code{\cmd{\acronym}\{\var{acronym}\}}] | |
| 78 | % Use for abbreviattions written in all capital letters, such as | |
| 79 | % \samp{NASA}. | |
| 80 | % \end{description} | |
| 81 | % If this sounds rather confusing, please see the Texinfo documentation | |
| 82 | % for more details. | |
| 83 | % | |
| 84 | % \DescribeMacro{\strong} | |
| 85 | % There is also a |\strong| command for emphasizing text more strongly | |
| 86 | % than with |\emph|. For example, |\strong{Note:}| gives \strong{Note:}. | |
| 87 | % | |
| 88 | % \DescribeMacro{\pkg} | |
| 89 | % Finally, use |\pkg| for indicating R packages. | |
| 90 | % | |
| 91 | % \subsection{Quotations and Examples} | |
| 92 | % | |
| 93 | % In addition to the standard \LaTeX{} for quotations and examples (such | |
| 94 | % as |quote|, |quotation|, |flushleft|, |center| and |flushright|), the | |
| 95 | % \pkg{\filename} package provides the following environments. | |
| 96 | % \begin{description} | |
| 97 | % \item[\code{example}] | |
| 98 | % Illustrate code, commands, and the like. The text is printed in a | |
| 99 | % fixed-width font, and indented but not filled. | |
| 100 | % \item[\code{smallexample}] | |
| 101 | % Similar to \code{example}, except that text is typeset in a smaller | |
| 102 | % font. | |
| 103 | % \end{description} | |
| 104 | % | |
| 105 | % \subsection{Mathematics} | |
| 106 | % | |
| 107 | % \DescribeMacro{\P} | |
| 108 | % \DescribeMacro{\E} | |
| 109 | % \DescribeMacro{\VAR} | |
| 110 | % \DescribeMacro{\COV} | |
| 111 | % \DescribeMacro{\COR} | |
| 112 | % The commands |\P|, |\E|, |\VAR|, |\COV|, and |\COR| produce symbols | |
| 113 | % for probability, expectation, variance, covariance and correlation. | |
| 114 | % For example, Chebyshev's inequality | |
| 115 | % \DeleteShortVerb{\|} | |
| 116 | % \begin{displaymath} | |
| 117 | % \P(|\xi-\E\xi|>\lambda) \le \frac{\VAR(\xi)}{\lambda^2}. | |
| 118 | % \end{displaymath} | |
| 119 | % can be coded as | |
| 120 | % \MakeShortVerb{\|} | |
| 121 | % \begin{quote} | |
| 122 | % \verb+\P(|\xi-\E\xi|>\lambda) \le \frac{\VAR(\xi)}{\lambda^2}+. | |
| 123 | % \end{quote} | |
| 124 | % | |
| 125 | % \DescribeMacro{\mathbb} | |
| 126 | % The symbols | |
| 127 | % \begin{displaymath} | |
| 128 | % \mathbb{N}\quad\mathbb{Z}\quad\mathbb{Q}\quad\mathbb{R}\quad\mathbb{C} | |
| 129 | % \end{displaymath} | |
| 130 | % for the positive integers, the integers, and the rational, real and | |
| 131 | % complex numbers, respectively, can be obtained using |\mathbb| from | |
| 132 | % package \pkg{amsfonts} as | |
| 133 | % \begin{quote} | |
| 134 | % |\mathbb{N}| |\mathbb{Z}| |\mathbb{Q}| |\mathbb{R}| |\mathbb{C}| | |
| 135 | % \end{quote} | |
| 136 | % | |
| 137 | % \section{The Code} | |
| 138 | % | |
| 139 | % \subsection{The Batch File} | |
| 140 | % | |
| 141 | % First comes the code for creating the batch file \file{\filename.ins} | |
| 142 | % which in turn can be used for producing the package and driver files. | |
| 143 | % | |
| 144 | % \begin{macrocode} | |
| 145 | %<*install> | |
| 146 | \begin{filecontents}{\filename.ins} | |
| 147 | % Simply TeX or LaTeX this file to extract various files from the source | |
| 148 | % file `Rnews.dtx'. | |
| 149 | \def\filedate{2001/01/05} \def\batchfile{Rnews.ins} \input | |
| 150 | docstrip.tex \preamble | |
| 151 | \endpreamble | |
| 152 | \generateFile{Rnews.drv}{t}{\from{Rnews.dtx}{driver}} | |
| 153 | \generateFile{Rnews.sty}{t}{\from{Rnews.dtx}{package}} | |
| 154 | \Msg{***********************************************************} | |
| 155 | \Msg{* For documentation, run LaTeX on Rnews.dtx or Rnews.drv. *} | |
| 156 | \Msg{***********************************************************} | |
| 157 | \end{filecontents} | |
| 158 | %</install> | |
| 159 | % \end{macrocode} | |
| 160 | % | |
| 161 | % \subsection{The Driver} | |
| 162 | % | |
| 163 | % Next comes the documentation driver file for \TeX{}, i.e., the file | |
| 164 | % that will produce the documentation you are currently reading. It | |
| 165 | % will be extracted from this file by the \texttt{docstrip} program. | |
| 166 | % Since it is the first code in the file one can alternatively process | |
| 167 | % this file directly with \LaTeXe{} to obtain the documentation. | |
| 168 | % | |
| 169 | % \begin{macrocode} | |
| 170 | %<*driver> | |
| 171 | \documentclass[fleqn]{ltxdoc} | |
| 172 | \usepackage[driver]{\filename} | |
| 173 | \renewcommand{\pkg}[1]{\textsf{#1}} | |
| 174 | \begin{document} | |
| 175 | \DocInput{\filename.dtx} | |
| 176 | \end{document} | |
| 177 | %</driver> | |
| 178 | % \end{macrocode} | |
| 179 | % | |
| 180 | % \subsection{The Code} | |
| 181 | % | |
| 182 | % Now comes the code for the package. | |
| 183 | % | |
| 184 | % It the current format is not \LaTeXe{}, we abort immediately. | |
| 185 | % Otherwise, we provide ourselves and show the current version of the | |
| 186 | % package on the screen and in the transscript file. | |
| 187 | % \begin{macrocode} | |
| 188 | %<*package> | |
| 189 | \NeedsTeXFormat{LaTeX2e}[1995/12/01] | |
| 190 | \ProvidesPackage{\filename}[\filedate\space\fileversion\space | |
| 191 | Rnews package] | |
| 192 | \typeout{Package: `\filename\space\fileversion \@spaces <\filedate>'} | |
| 193 | \typeout{English documentation as of <\docdate>} | |
| 194 | % \end{macrocode} | |
| 195 | % | |
| 196 | % Next, we set up a more or less trivial option handler. We use option | |
| 197 | % `driver' for conditionalizing package code we do not want executed | |
| 198 | % when typesetting the driver file. | |
| 199 | % \begin{macrocode} | |
| 200 | \RequirePackage{ifthen} | |
| 201 | \newboolean{Rnews@driver} | |
| 202 | \DeclareOption{driver}{\setboolean{Rnews@driver}{true}} | |
| 203 | \DeclareOption*{\PackageWarning{\filename}{Unknown option | |
| 204 | `\CurrentOption'}} | |
| 205 | \ProcessOptions\relax | |
| 206 | % \end{macrocode} | |
| 207 | % | |
| 208 | % Now comes the real code. | |
| 209 | % | |
| 210 | % \begin{macrocode} | |
| 211 | \ifthenelse{\boolean{Rnews@driver}}{}{ | |
| 212 | % \end{macrocode} | |
| 213 | % | |
| 214 | % First we load some utility packages. | |
| 215 | % \begin{macrocode} | |
| 216 | \RequirePackage{multicol,graphicx,color,fancyhdr,hyperref} | |
| 217 | % \end{macrocode} | |
| 218 | % | |
| 219 | % \subsubsection{Basic Structure} | |
| 220 | % | |
| 221 | % Issues of of \emph{R News} are created from the standard \LaTeX{} | |
| 222 | % document class \pkg{report}. Individual articles correspond to | |
| 223 | % chapters, and are contained in |article| environments. This makes it | |
| 224 | % easy to have figures counted within articles and hence hyperlinked | |
| 225 | % correctly. | |
| 226 | % | |
| 227 | % Basic front matter information about the issue: volume, number, and | |
| 228 | % date. | |
| 229 | % \begin{macrocode} | |
| 230 | \newcommand{\volume}[1]{\def\Rnews@volume{#1}} | |
| 231 | \newcommand{\volnumber}[1]{\def\Rnews@number{#1}} | |
| 232 | \renewcommand{\date}[1]{\def\Rnews@date{#1}} | |
| 233 | % \end{macrocode} | |
| 234 | % | |
| 235 | % We do not want numbered sections. | |
| 236 | % \begin{macrocode} | |
| 237 | \setcounter{secnumdepth}{-1} | |
| 238 | % \end{macrocode} | |
| 239 | % | |
| 240 | % \begin{macro}{\author} | |
| 241 | % \begin{macro}{\title} | |
| 242 | % \begin{macro}{\subtitle} | |
| 243 | % An article has an author, a title, and optionally a subtitle. We use | |
| 244 | % the obvious commands for specifying these. | |
| 245 | % \begin{macrocode} | |
| 246 | \renewcommand{\author}[1]{\def\Rnews@author{#1}} | |
| 247 | \renewcommand{\title}[1]{\def\Rnews@title{#1}} | |
| 248 | \newcommand{\subtitle}[1]{\def\Rnews@subtitle{#1}} | |
| 249 | % \end{macrocode} | |
| 250 | % \end{macro} | |
| 251 | % \end{macro} | |
| 252 | % \end{macro} | |
| 253 | % | |
| 254 | % \begin{environment}{article} | |
| 255 | % Environment |article| clears the article header information its begin | |
| 256 | % and restores single column mode at its end. | |
| 257 | % \begin{macrocode} | |
| 258 | \newenvironment{article}{% | |
| 259 | \author{}\title{}\subtitle{}}{\end{multicols}} | |
| 260 | % \end{macrocode} | |
| 261 | % \end{environment} | |
| 262 | % | |
| 263 | % \begin{macro}{\maketitle} | |
| 264 | % The real work is done by a redefined version of |\maketitle|, which | |
| 265 | % also switches to double column mode. Note that even though we do not | |
| 266 | % want chapters (articles) numbered, we need to increment the chapter | |
| 267 | % counter, so that figures get correct labelling. | |
| 268 | % \begin{macrocode} | |
| 269 | \renewcommand{\maketitle}{ | |
| 270 | \chapter{\Rnews@title} | |
| 271 | \refstepcounter{chapter} | |
| 272 | \begin{multicols}{2} | |
| 273 | \ifx\empty\Rnews@subtitle\else\par\addvspace{\baselineskip} | |
| 274 | \noindent\textbf{\Rnews@subtitle}\fi | |
| 275 | \ifx\empty\Rnews@author\else\par\addvspace{\baselineskip} | |
| 276 | \noindent\textit{\Rnews@author}\fi} | |
| 277 | % \end{macrocode} | |
| 278 | % \end{macro} | |
| 279 | % | |
| 280 | % Now for some ugly redefinitions. We do not want articles to start a | |
| 281 | % new page. | |
| 282 | % \begin{macrocode} | |
| 283 | \renewcommand\chapter{\secdef\@chapter\@schapter} | |
| 284 | % \end{macrocode} | |
| 285 | % TOC entries for articles (chapters) should really look like sections. | |
| 286 | % \begin{macrocode} | |
| 287 | \renewcommand*\l@chapter{\@dottedtocline{0}{0pt}{1em}} | |
| 288 | % \end{macrocode} | |
| 289 | % We need to adjust vertical spacing in |\@makechapterhead|: extra space | |
| 290 | % before the title only if not at the beginning, no extra space after | |
| 291 | % it. | |
| 292 | % \begin{macrocode} | |
| 293 | \def\@makechapterhead#1{% | |
| 294 | \addvspace{2\baselineskip}% | |
| 295 | {\parindent \z@ \raggedright \normalfont | |
| 296 | \ifnum \c@secnumdepth >\m@ne | |
| 297 | \huge\bfseries \@chapapp\space \thechapter | |
| 298 | \par\nobreak | |
| 299 | \vskip 20\p@ | |
| 300 | \fi | |
| 301 | \interlinepenalty\@M | |
| 302 | \Huge \bfseries #1\par\nobreak}} | |
| 303 | % \end{macrocode} | |
| 304 | % We want bibliographies as starred sections within articles. As the | |
| 305 | % standard |thebibliography| environment uses |chapter*|, we simply | |
| 306 | % redefine the latter according to our needs. | |
| 307 | % \begin{macrocode} | |
| 308 | \def\@schapter#1{\section*#1} | |
| 309 | % \end{macrocode} | |
| 310 | % | |
| 311 | % Package \pkg{multicol}, which is used for producing two-column output, | |
| 312 | % only allows for starred (single-column) floats (figures and tables). | |
| 313 | % Therefore, we provide a simple non-floating |figure| environment | |
| 314 | % ourselves. | |
| 315 | % \begin{macrocode} | |
| 316 | \renewenvironment{figure}[1][]{% | |
| 317 | \def\@captype{figure} | |
| 318 | \begin{minipage}{0.9\columnwidth}}{ | |
| 319 | \end{minipage}\par\addvspace{\baselineskip}} | |
| 320 | % \end{macrocode} | |
| 321 | % Equations, figures and tables are counted within articles, but we do | |
| 322 | % not show the article number. | |
| 323 | % \begin{macrocode} | |
| 324 | \renewcommand{\theequation}{\@arabic\c@equation} | |
| 325 | \renewcommand{\thefigure}{\@arabic\c@figure} | |
| 326 | \renewcommand{\thetable}{\@arabic\c@table} | |
| 327 | % \end{macrocode} | |
| 328 | % | |
| 329 | % \begin{macro}{\tableofcontents} | |
| 330 | % Need to provide our own version of |\tableofcontents| (no fiddling | |
| 331 | % with the number of columns). Note that |\section*| is really the same | |
| 332 | % as |\chapter*|). | |
| 333 | % \begin{macrocode} | |
| 334 | \renewcommand{\contentsname}{Contents of this issue:} | |
| 335 | \renewcommand\tableofcontents{% | |
| 336 | \section*{\contentsname | |
| 337 | \@mkboth{% | |
| 338 | \MakeUppercase\contentsname}{\MakeUppercase\contentsname}}% | |
| 339 | \@starttoc{toc}} | |
| 340 | % \end{macrocode} | |
| 341 | % \end{macro} | |
| 342 | % \begin{macro}{\titlepage} | |
| 343 | % The title page of each issue features logo et al at the top and the | |
| 344 | % TOC. We start with the top. | |
| 345 | % \begin{macrocode} | |
| 346 | \renewcommand{\titlepage}{% | |
| 347 | \noindent | |
| 348 | \rule{\textwidth}{1pt}\\[-.8\baselineskip] | |
| 349 | \rule{\textwidth}{.5pt} | |
| 350 | \begin{center} | |
| 351 | \includegraphics[height=2cm]{Rlogo}\hspace{7mm} | |
| 352 | \fontsize{2cm}{2cm}\selectfont | |
| 353 | News | |
| 354 | \end{center} | |
| 355 | The Newsletter of the R Project\hfill | |
| 356 | Volume \Rnews@volume/\Rnews@number, \Rnews@date\\[-.5\baselineskip] | |
| 357 | \rule{\textwidth}{.5pt}\\[-.8\baselineskip] | |
| 358 | \rule{\textwidth}{1pt} | |
| 359 | \vspace{1cm} | |
| 360 | % \end{macrocode} | |
| 361 | % Now set up the header and footer information for the rest of the | |
| 362 | % document. | |
| 363 | % \begin{macrocode} | |
| 364 | \fancyhf{} | |
| 365 | \fancyhead[L]{Vol.~\Rnews@volume/\Rnews@number, \Rnews@date} | |
| 366 | \fancyhead[R]{\thepage} | |
| 367 | \fancyfoot[L]{R News} | |
| 368 | \fancyfoot[R]{ISSN 1609-3631} | |
| 369 | \thispagestyle{empty} | |
| 370 | % \end{macrocode} | |
| 371 | % And finally, put the TOC at the bottom in a framed box. Note the way | |
| 372 | % |tocdepth| is adjusted before and after producing the TOC: thus, we | |
| 373 | % can ensure that only articles show up in the printed TOC, but that in | |
| 374 | % the PDF version, bookmarks are created for sections and subsections as | |
| 375 | % well (provided that the non-starred forms are used). | |
| 376 | % \begin{macrocode} | |
| 377 | \begin{bottombox} | |
| 378 | \begin{multicols}{2} | |
| 379 | \setcounter{tocdepth}{0} | |
| 380 | \tableofcontents | |
| 381 | \setcounter{tocdepth}{2} | |
| 382 | \end{multicols} | |
| 383 | \end{bottombox}} | |
| 384 | % \end{macrocode} | |
| 385 | % \end{macro} | |
| 386 | % | |
| 387 | % \subsubsection{Layout, Fonts and Color} | |
| 388 | % | |
| 389 | % \paragraph{Layout.} | |
| 390 | % We set the basic layout parameters in a way that printouts should be | |
| 391 | % fine for both A4 and Letter paper. | |
| 392 | % \begin{macrocode} | |
| 393 | \setlength{\textheight}{250mm} | |
| 394 | \setlength{\topmargin}{-10mm} | |
| 395 | \setlength{\textwidth}{17cm} | |
| 396 | \setlength{\oddsidemargin}{-6mm} | |
| 397 | \setlength{\columnseprule}{.1pt} | |
| 398 | \setlength{\columnsep}{20pt} | |
| 399 | % \end{macrocode} | |
| 400 | % | |
| 401 | % \paragraph{Fonts.} | |
| 402 | % We use the following fonts (all with T1 encoding): | |
| 403 | % \begin{center} | |
| 404 | % \begin{tabular}{lp{0.8\textwidth}} | |
| 405 | % rm & palatino \\ | |
| 406 | % tt & almost european (computer modern working with T1) \\ | |
| 407 | % & Reason for aett: uses less horizontal space than courier, | |
| 408 | % which is better for example code \\ | |
| 409 | % sf & almost european \\ | |
| 410 | % math & palatino | |
| 411 | % \end{tabular} | |
| 412 | % \end{center} | |
| 413 | % | |
| 414 | % \begin{macrocode} | |
| 415 | \RequirePackage{ae,mathpple} | |
| 416 | \RequirePackage[T1]{fontenc} | |
| 417 | \renewcommand{\rmdefault}{ppl} | |
| 418 | \renewcommand{\sfdefault}{aess} | |
| 419 | \renewcommand{\ttdefault}{aett} | |
| 420 | % \end{macrocode} | |
| 421 | % | |
| 422 | % \paragraph{Colors.} These are actually used for |\hypersetup| but we | |
| 423 | % do not call this here, although we should. | |
| 424 | % \marginpar{FIXME} | |
| 425 | % \begin{macrocode} | |
| 426 | \definecolor{Red}{rgb}{0.7,0,0} | |
| 427 | \definecolor{Blue}{rgb}{0,0,0.8} | |
| 428 | \definecolor{hellgrau}{rgb}{0.55,0.55,0.55} | |
| 429 | % \end{macrocode} | |
| 430 | % | |
| 431 | % \subsubsection{Miscellania} | |
| 432 | % | |
| 433 | % \begin{macrocode} | |
| 434 | \newcommand{\R}{R} | |
| 435 | \newcommand{\address}[1]{\addvspace{\baselineskip}\noindent\emph{#1}} | |
| 436 | \newcommand{\email}[1]{\href{mailto:#1}{\normalfont\texttt{#1}}} | |
| 437 | % \end{macrocode} | |
| 438 | % | |
| 439 | % \begin{environment}{bottombox} | |
| 440 | % Used for creating the TOC and the back matter editorial information. | |
| 441 | % \begin{macrocode} | |
| 442 | \newsavebox{\Rnews@box} | |
| 443 | \newlength{\Rnews@len} | |
| 444 | \newenvironment{bottombox}{% | |
| 445 | \begin{figure*}[b] | |
| 446 | \begin{center} | |
| 447 | \noindent | |
| 448 | \begin{lrbox}{\Rnews@box} | |
| 449 | \begin{minipage}{0.99\textwidth}}{% | |
| 450 | \end{minipage} | |
| 451 | \end{lrbox} | |
| 452 | \addtolength{\Rnews@len}{\fboxsep} | |
| 453 | \addtolength{\Rnews@len}{\fboxrule} | |
| 454 | \hspace*{-\Rnews@len}\fbox{\usebox{\Rnews@box}} | |
| 455 | \end{center} | |
| 456 | \end{figure*}} | |
| 457 | % \end{macrocode} | |
| 458 | % \end{environment} | |
| 459 | % | |
| 460 | % \begin{environment}{boxedverbatim} | |
| 461 | % This does not seem to be used any more. | |
| 462 | % \marginpar{FIXME} | |
| 463 | % \begin{macrocode} | |
| 464 | \newenvironment{boxedverbatim}{% | |
| 465 | \begin{lrbox}{\Rnews@box} | |
| 466 | \begin{smallverbatim}}{% | |
| 467 | \end{smallverbatim} | |
| 468 | \end{lrbox} | |
| 469 | \hspace*{-\fboxsep}\fbox{\usebox{\Rnews@box}}} | |
| 470 | % \end{macrocode} | |
| 471 | % \end{environment} | |
| 472 | % | |
| 473 | % Finally, we turn on fancy page style. | |
| 474 | % \begin{macrocode} | |
| 475 | \pagestyle{fancy} | |
| 476 | } % \ifthenelse{\boolean{Rnews@driver}} | |
| 477 | % \end{macrocode} | |
| 478 | % | |
| 479 | % \subsubsection{Marking Words and Phrases} | |
| 480 | % | |
| 481 | % Simple font selection is not good enough. For example, |\texttt{--}| | |
| 482 | % gives `\texttt{--}', i.e., an endash in typewriter font. Hence, we | |
| 483 | % need to turn off ligatures, which currently only happens for commands | |
| 484 | % |\code| and |\samp| and the ones derived from them. Hyphenation is | |
| 485 | % another issue; it should really be turned off inside |\samp|. And | |
| 486 | % most importantly, \LaTeX{} special characters are a nightmare. E.g., | |
| 487 | % one needs |\~{}| to produce a tilde in a file name marked by |\file|. | |
| 488 | % Perhaps a few years ago, most users would have agreed that this may be | |
| 489 | % unfortunate but should not be changed to ensure consistency. But with | |
| 490 | % the advent of the WWW and the need for getting `|~|' and `|#|' into | |
| 491 | % URLs, commands which only treat the escape and grouping characters | |
| 492 | % specially have gained acceptance (in fact, this is also what | |
| 493 | % \pkg{alltt} does, and hence environments based on it such as our | |
| 494 | % |smallexample|). Hence, in the long run we should implement the same | |
| 495 | % for |\code|, |\kbd|, |\samp|, |\var|, and |\file|. (The other | |
| 496 | % Texinfo-style commands do not need this.) | |
| 497 | % | |
| 498 | % \begin{macrocode} | |
| 499 | %\newcommand\code{\bgroup\@noligs\@codex} | |
| 500 | \newcommand\code{\bgroup\@codex} | |
| 501 | \def\@codex#1{{\normalfont\ttfamily\hyphenchar\font=-1 #1}\egroup} | |
| 502 | \newcommand{\kbd}[1]{{\normalfont\texttt{#1}}} | |
| 503 | \newcommand{\key}[1]{{\normalfont\texttt{\uppercase{#1}}}} | |
| 504 | \newcommand\samp{`\bgroup\@noligs\@sampx} | |
| 505 | \def\@sampx#1{{\normalfont\texttt{#1}}\egroup'} | |
| 506 | \newcommand{\var}[1]{{\normalfont\textsl{#1}}} | |
| 507 | \let\env=\code | |
| 508 | \newcommand{\file}[1]{{`\normalfont\textsf{#1}'}} | |
| 509 | \let\command=\code | |
| 510 | \let\option=\samp | |
| 511 | \newcommand{\dfn}[1]{{\normalfont\textsl{#1}}} | |
| 512 | \newcommand{\acronym}[1]{{\normalfont\textsc{\lowercase{#1}}}} | |
| 513 | \newcommand{\strong}[1]{{\normalfont\fontseries{b}\selectfont #1}} | |
| 514 | \let\pkg=\strong | |
| 515 | % \end{macrocode} | |
| 516 | % | |
| 517 | % \subsubsection{Quotations and Examples} | |
| 518 | % | |
| 519 | % \begin{macrocode} | |
| 520 | \RequirePackage{alltt} | |
| 521 | \newenvironment{example}{\begin{alltt}}{\end{alltt}} | |
| 522 | \newenvironment{smallexample}{\begin{alltt}\small}{\end{alltt}} | |
| 523 | \newenvironment{display}{\list{}{}\item\relax}{\endlist} | |
| 524 | % \end{macrocode} | |
| 525 | % | |
| 526 | % \subsubsection{Mathematics} | |
| 527 | % | |
| 528 | % \begin{macro}{\operatorname} | |
| 529 | % The implementation of |\operatorname| is similar to the mechanism | |
| 530 | % \LaTeXe{} uses for functions like sin and cos, and simpler than the | |
| 531 | % one of \AmSLaTeX{}. We use |\providecommand| for the definition in | |
| 532 | % order to keep the one of the \pkg{amstex} if this package has | |
| 533 | % already been loaded. | |
| 534 | % \begin{macrocode} | |
| 535 | \providecommand{\operatorname}[1]{% | |
| 536 | \mathop{\operator@font#1}\nolimits} | |
| 537 | % \end{macrocode} | |
| 538 | % \end{macro} | |
| 539 | % | |
| 540 | % \begin{macro}{\P} | |
| 541 | % \begin{macro}{\E} | |
| 542 | % \begin{macro}{\VAR} | |
| 543 | % \begin{macro}{\COV} | |
| 544 | % \begin{macro}{\COR} | |
| 545 | % Next, we provide commands for probability, expectation, variance, | |
| 546 | % covariance and correlation which are obviously useful in probability | |
| 547 | % theory and statistics. | |
| 548 | % (Of course, originally |\P| gives \mathhexbox27B.) | |
| 549 | % \begin{macrocode} | |
| 550 | \renewcommand{\P}{% | |
| 551 | \mathop{\operator@font I\hspace{-1.5pt}P\hspace{.13pt}}} | |
| 552 | \newcommand{\E}{% | |
| 553 | \mathop{\operator@font I\hspace{-1.5pt}E\hspace{.13pt}}} | |
| 554 | \newcommand{\VAR}{\operatorname{var}} | |
| 555 | \newcommand{\COV}{\operatorname{cov}} | |
| 556 | \newcommand{\COR}{\operatorname{cor}} | |
| 557 | % \end{macrocode} | |
| 558 | % \end{macro} | |
| 559 | % \end{macro} | |
| 560 | % \end{macro} | |
| 561 | % \end{macro} | |
| 562 | % \end{macro} | |
| 563 | % | |
| 564 | % Finally, we load package \pkg{amsfonts} so that |\mathbb| is available | |
| 565 | % for producing the symbols for positive integers etc. | |
| 566 | % \begin{macrocode} | |
| 567 | \RequirePackage{amsfonts} | |
| 568 | % \end{macrocode} | |
| 569 | % | |
| 570 | % This ends the implementation of the \pkg{\filename} package. | |
| 571 | % \begin{macrocode} | |
| 572 | %</package> | |
| 573 | % \end{macrocode} |
| 0 | %% | |
| 1 | %% This is file `Rnews.sty', | |
| 2 | %% generated with the docstrip utility. | |
| 3 | %% | |
| 4 | %% The original source files were: | |
| 5 | %% | |
| 6 | %% Rnews.dtx (with options: `package') | |
| 7 | %% | |
| 8 | %% IMPORTANT NOTICE: | |
| 9 | %% | |
| 10 | %% For the copyright see the source file. | |
| 11 | %% | |
| 12 | %% Any modified versions of this file must be renamed | |
| 13 | %% with new filenames distinct from Rnews.sty. | |
| 14 | %% | |
| 15 | %% For distribution of the original source see the terms | |
| 16 | %% for copying and modification in the file Rnews.dtx. | |
| 17 | %% | |
| 18 | %% This generated file may be distributed as long as the | |
| 19 | %% original source files, as listed above, are part of the | |
| 20 | %% same distribution. (The sources need not necessarily be | |
| 21 | %% in the same archive or directory.) | |
| 22 | \def\fileversion{v0.3.1} | |
| 23 | \def\filename{Rnews} | |
| 24 | \def\filedate{2001/09/04} | |
| 25 | \def\docdate {2001/09/04} | |
| 26 | %% | |
| 27 | %% Package `Rnews' to use with LaTeX2e | |
| 28 | %% Copyright (C) 2001 by the R Core Development Team | |
| 29 | %% Please report errors to KH or FL | |
| 30 | %% | |
| 31 | %% -*- LaTeX -*- | |
| 32 | \NeedsTeXFormat{LaTeX2e}[1995/12/01] | |
| 33 | \ProvidesPackage{\filename}[\filedate\space\fileversion\space | |
| 34 | Rnews package] | |
| 35 | \typeout{Package: `\filename\space\fileversion \@spaces <\filedate>'} | |
| 36 | \typeout{English documentation as of <\docdate>} | |
| 37 | \RequirePackage{ifthen} | |
| 38 | \newboolean{Rnews@driver} | |
| 39 | \DeclareOption{driver}{\setboolean{Rnews@driver}{true}} | |
| 40 | \DeclareOption*{\PackageWarning{\filename}{Unknown option | |
| 41 | `\CurrentOption'}} | |
| 42 | \ProcessOptions\relax | |
| 43 | \ifthenelse{\boolean{Rnews@driver}}{}{ | |
| 44 | \RequirePackage{multicol,graphicx,color,fancyhdr,hyperref} | |
| 45 | \newcommand{\volume}[1]{\def\Rnews@volume{#1}} | |
| 46 | \newcommand{\volnumber}[1]{\def\Rnews@number{#1}} | |
| 47 | \renewcommand{\date}[1]{\def\Rnews@date{#1}} | |
| 48 | \setcounter{secnumdepth}{-1} | |
| 49 | \renewcommand{\author}[1]{\def\Rnews@author{#1}} | |
| 50 | \renewcommand{\title}[1]{\def\Rnews@title{#1}} | |
| 51 | \newcommand{\subtitle}[1]{\def\Rnews@subtitle{#1}} | |
| 52 | \newenvironment{article}{% | |
| 53 | \author{}\title{}\subtitle{}}{\end{multicols}} | |
| 54 | \renewcommand{\maketitle}{ | |
| 55 | \chapter{\Rnews@title} | |
| 56 | \refstepcounter{chapter} | |
| 57 | \begin{multicols}{2} | |
| 58 | \ifx\empty\Rnews@subtitle\else\par\addvspace{\baselineskip} | |
| 59 | \noindent\textbf{\Rnews@subtitle}\fi | |
| 60 | \ifx\empty\Rnews@author\else\par\addvspace{\baselineskip} | |
| 61 | \noindent\textit{\Rnews@author}\fi} | |
| 62 | \renewcommand\chapter{\secdef\@chapter\@schapter} | |
| 63 | \renewcommand*\l@chapter{\@dottedtocline{0}{0pt}{1em}} | |
| 64 | \def\@makechapterhead#1{% | |
| 65 | \addvspace{2\baselineskip}% | |
| 66 | {\parindent \z@ \raggedright \normalfont | |
| 67 | \ifnum \c@secnumdepth >\m@ne | |
| 68 | \huge\bfseries \@chapapp\space \thechapter | |
| 69 | \par\nobreak | |
| 70 | \vskip 20\p@ | |
| 71 | \fi | |
| 72 | \interlinepenalty\@M | |
| 73 | \Huge \bfseries #1\par\nobreak}} | |
| 74 | \def\@schapter#1{\section*#1} | |
| 75 | \renewenvironment{figure}[1][]{% | |
| 76 | \def\@captype{figure} | |
| 77 | \begin{minipage}{0.9\columnwidth}}{ | |
| 78 | \end{minipage}\par\addvspace{\baselineskip}} | |
| 79 | \renewcommand{\theequation}{\@arabic\c@equation} | |
| 80 | \renewcommand{\thefigure}{\@arabic\c@figure} | |
| 81 | \renewcommand{\thetable}{\@arabic\c@table} | |
| 82 | \renewcommand{\contentsname}{Contents of this issue:} | |
| 83 | \renewcommand\tableofcontents{% | |
| 84 | \section*{\contentsname | |
| 85 | \@mkboth{% | |
| 86 | \MakeUppercase\contentsname}{\MakeUppercase\contentsname}}% | |
| 87 | \@starttoc{toc}} | |
| 88 | \renewcommand{\titlepage}{% | |
| 89 | \noindent | |
| 90 | \rule{\textwidth}{1pt}\\[-.8\baselineskip] | |
| 91 | \rule{\textwidth}{.5pt} | |
| 92 | \begin{center} | |
| 93 | \includegraphics[height=2cm]{Rlogo}\hspace{7mm} | |
| 94 | \fontsize{2cm}{2cm}\selectfont | |
| 95 | News | |
| 96 | \end{center} | |
| 97 | The Newsletter of the R Project\hfill | |
| 98 | Volume \Rnews@volume/\Rnews@number, \Rnews@date\\[-.5\baselineskip] | |
| 99 | \rule{\textwidth}{.5pt}\\[-.8\baselineskip] | |
| 100 | \rule{\textwidth}{1pt} | |
| 101 | \vspace{1cm} | |
| 102 | \fancyhf{} | |
| 103 | \fancyhead[L]{Vol.~\Rnews@volume/\Rnews@number, \Rnews@date} | |
| 104 | \fancyhead[R]{\thepage} | |
| 105 | \fancyfoot[L]{R News} | |
| 106 | \fancyfoot[R]{ISSN 1609-3631} | |
| 107 | \thispagestyle{empty} | |
| 108 | \begin{bottombox} | |
| 109 | \begin{multicols}{2} | |
| 110 | \setcounter{tocdepth}{0} | |
| 111 | \tableofcontents | |
| 112 | \setcounter{tocdepth}{2} | |
| 113 | \end{multicols} | |
| 114 | \end{bottombox}} | |
| 115 | \setlength{\textheight}{250mm} | |
| 116 | \setlength{\topmargin}{-10mm} | |
| 117 | \setlength{\textwidth}{17cm} | |
| 118 | \setlength{\oddsidemargin}{-6mm} | |
| 119 | \setlength{\columnseprule}{.1pt} | |
| 120 | \setlength{\columnsep}{20pt} | |
| 121 | \RequirePackage{ae,mathpple} | |
| 122 | \RequirePackage[T1]{fontenc} | |
| 123 | \renewcommand{\rmdefault}{ppl} | |
| 124 | \renewcommand{\sfdefault}{aess} | |
| 125 | \renewcommand{\ttdefault}{aett} | |
| 126 | \definecolor{Red}{rgb}{0.7,0,0} | |
| 127 | \definecolor{Blue}{rgb}{0,0,0.8} | |
| 128 | \definecolor{hellgrau}{rgb}{0.55,0.55,0.55} | |
| 129 | \newcommand{\R}{R} | |
| 130 | \newcommand{\address}[1]{\addvspace{\baselineskip}\noindent\emph{#1}} | |
| 131 | \newcommand{\email}[1]{\href{mailto:#1}{\normalfont\texttt{#1}}} | |
| 132 | \newsavebox{\Rnews@box} | |
| 133 | \newlength{\Rnews@len} | |
| 134 | \newenvironment{bottombox}{% | |
| 135 | \begin{figure*}[b] | |
| 136 | \begin{center} | |
| 137 | \noindent | |
| 138 | \begin{lrbox}{\Rnews@box} | |
| 139 | \begin{minipage}{0.99\textwidth}}{% | |
| 140 | \end{minipage} | |
| 141 | \end{lrbox} | |
| 142 | \addtolength{\Rnews@len}{\fboxsep} | |
| 143 | \addtolength{\Rnews@len}{\fboxrule} | |
| 144 | \hspace*{-\Rnews@len}\fbox{\usebox{\Rnews@box}} | |
| 145 | \end{center} | |
| 146 | \end{figure*}} | |
| 147 | \newenvironment{boxedverbatim}{% | |
| 148 | \begin{lrbox}{\Rnews@box} | |
| 149 | \begin{smallverbatim}}{% | |
| 150 | \end{smallverbatim} | |
| 151 | \end{lrbox} | |
| 152 | \hspace*{-\fboxsep}\fbox{\usebox{\Rnews@box}}} | |
| 153 | \pagestyle{fancy} | |
| 154 | } % \ifthenelse{\boolean{Rnews@driver}} | |
| 155 | \newcommand\code{\bgroup\@codex} | |
| 156 | \def\@codex#1{{\normalfont\ttfamily\hyphenchar\font=-1 #1}\egroup} | |
| 157 | \newcommand{\kbd}[1]{{\normalfont\texttt{#1}}} | |
| 158 | \newcommand{\key}[1]{{\normalfont\texttt{\uppercase{#1}}}} | |
| 159 | \newcommand\samp{`\bgroup\@noligs\@sampx} | |
| 160 | \def\@sampx#1{{\normalfont\texttt{#1}}\egroup'} | |
| 161 | \newcommand{\var}[1]{{\normalfont\textsl{#1}}} | |
| 162 | \let\env=\code | |
| 163 | \newcommand{\file}[1]{{`\normalfont\textsf{#1}'}} | |
| 164 | \let\command=\code | |
| 165 | \let\option=\samp | |
| 166 | \newcommand{\dfn}[1]{{\normalfont\textsl{#1}}} | |
| 167 | \newcommand{\acronym}[1]{{\normalfont\textsc{\lowercase{#1}}}} | |
| 168 | \newcommand{\strong}[1]{{\normalfont\fontseries{b}\selectfont #1}} | |
| 169 | \let\pkg=\strong | |
| 170 | \RequirePackage{alltt} | |
| 171 | \newenvironment{example}{\begin{alltt}}{\end{alltt}} | |
| 172 | \newenvironment{smallexample}{\begin{alltt}\small}{\end{alltt}} | |
| 173 | \newenvironment{display}{\list{}{}\item\relax}{\endlist} | |
| 174 | \providecommand{\operatorname}[1]{% | |
| 175 | \mathop{\operator@font#1}\nolimits} | |
| 176 | \renewcommand{\P}{% | |
| 177 | \mathop{\operator@font I\hspace{-1.5pt}P\hspace{.13pt}}} | |
| 178 | \newcommand{\E}{% | |
| 179 | \mathop{\operator@font I\hspace{-1.5pt}E\hspace{.13pt}}} | |
| 180 | \newcommand{\VAR}{\operatorname{var}} | |
| 181 | \newcommand{\COV}{\operatorname{cov}} | |
| 182 | \newcommand{\COR}{\operatorname{cor}} | |
| 183 | \RequirePackage{amsfonts} | |
| 184 | \endinput | |
| 185 | %% | |
| 186 | %% End of file `Rnews.sty'. |
Binary diff not shown
| 0 | \documentclass{report} | |
| 1 | \usepackage{Rnews} | |
| 2 | \begin{document} | |
| 3 | ||
| 4 | \author{by Gregory R. Warnes} | |
| 5 | \title{The gregmisc package: something for everyone} | |
| 6 | \subtitle{} | |
| 7 | ||
| 8 | \maketitle | |
| 9 | ||
| 10 | The gregmisc package is a repository for functions that I find myself | |
| 11 | needing but that don't seem to be available somewhere else. In | |
| 12 | contrast to many packages, it is not organized thematically, rather | |
| 13 | it contains a hodge-podge of different routines that make my life a | |
| 14 | little easer. | |
| 15 | ||
| 16 | I've taken the time to bundle these functions up as a package for | |
| 17 | three reasons, first to share my efforts with others, second to get | |
| 18 | feedback (particularly bug reports and feature enhancements), and | |
| 19 | third to force myself to properly document and test the code. | |
| 20 | ||
| 21 | The function in the gregmisc library fall into six general areas: | |
| 22 | permutations and combinations, tools for linear models, plots, data | |
| 23 | manipulation, fixed or extended versions of existing functions, and other. | |
| 24 | ||
| 25 | \begin{enumerate} | |
| 26 | ||
| 27 | ||
| 28 | \item{permutation and combinations} | |
| 29 | ||
| 30 | \begin{description} | |
| 31 | \item[combinations]{ Enumerate the combinations of the elements of a vector} | |
| 32 | \item[permutations]{ Enumerate the permutations of the elements of a vector} | |
| 33 | \item[factorial]{ Compute the factorial function} | |
| 34 | \end{description} | |
| 35 | ||
| 36 | \item{tools for linear models} | |
| 37 | ||
| 38 | \begin{description} | |
| 39 | \item[ci]{ Compute confidence intervals} | |
| 40 | \item[contrast.lm]{ Compute (and test) arbitrary single-term | |
| 41 | contrasts for regression objects} | |
| 42 | \item[estimable]{ Compute and test estimable linear functions of | |
| 43 | the fitted coefficients (including contrasts) of regression objects} | |
| 44 | \item[glh.test]{ Test a general linear hypothesis for regression objects} | |
| 45 | ||
| 46 | \end{description} | |
| 47 | ||
| 48 | \item{plots} | |
| 49 | \begin{description} | |
| 50 | \item[boxplot.n]{Produce a boxplot annotated with the number of observations} | |
| 51 | \item[plotCI]{ Plot error bars} | |
| 52 | \item[plotmeans]{ Plot group means and confidence intervals} | |
| 53 | \item[wapply]{ Compute the value of a function over a local region of | |
| 54 | an x-y plot} | |
| 55 | \item[space]{ Deterministically space points in an x-y plot so they don't | |
| 56 | overlap.} | |
| 57 | \item[hist2d]{ Create and Plot a 2-dimensional histogram.} | |
| 58 | \item[bandplot] {Plot x-y points with locally smoothed mean and standard deviation} | |
| 59 | ||
| 60 | \end{description} | |
| 61 | ||
| 62 | \item{data manipulation} | |
| 63 | ||
| 64 | \begin{description} | |
| 65 | \item[combine]{ Combine R objects (such as dataframes) and add an | |
| 66 | additional column labeling the source} | |
| 67 | \item[rename.vars]{ Rename variables in a dataframe} | |
| 68 | \end{description} | |
| 69 | ||
| 70 | \item{fixed or extended versions of current functions} | |
| 71 | ||
| 72 | \begin{description} | |
| 73 | \item[lowess]{ Extend built-in \verb+lowess+ function to handle model | |
| 74 | formulae } | |
| 75 | \item[plot.lm]{ Extend the built-in \verb+plot.lm+ function: } | |
| 76 | \begin{itemize} | |
| 77 | \item residual plots: add rug, zero line, mean and 1-sigma smooths | |
| 78 | \item residual quantile plots: add \verb+qqline+ | |
| 79 | \item add plots of each predictor against the residuals. | |
| 80 | \end{itemize} | |
| 81 | \end{description} | |
| 82 | ||
| 83 | \item{other} | |
| 84 | ||
| 85 | \begin{description} | |
| 86 | \item[running]{ Apply a function over adjacent subsets of a vector} | |
| 87 | \end{description} | |
| 88 | ||
| 89 | \end{enumerate} | |
| 90 | ||
| 91 | I welcome comments and contributions. The current package includes | |
| 92 | code by Ben Bolker, Bendix Carstensen, Don MacQueen, and William | |
| 93 | Venables. | |
| 94 | ||
| 95 | ||
| 96 | \address{Gregory R. Warnes \\ | |
| 97 | Pfizer Global Research and Development \\ | |
| 98 | \emph{gregory\_r\_warnes$@$groton.pfizer.com} } %%!!!%% | |
| 99 | ||
| 100 | ||
| 101 | \end{multicols} %%!!!%% | |
| 102 | ||
| 103 | \end{document} |
| 0 | package IO::AtomicFile; | |
| 1 | ||
| 2 | ### DOCUMENTATION AT BOTTOM OF FILE | |
| 3 | ||
| 4 | # Be strict: | |
| 5 | use strict; | |
| 6 | ||
| 7 | # External modules: | |
| 8 | use IO::File; | |
| 9 | ||
| 10 | ||
| 11 | #------------------------------ | |
| 12 | # | |
| 13 | # GLOBALS... | |
| 14 | # | |
| 15 | #------------------------------ | |
| 16 | use vars qw($VERSION @ISA); | |
| 17 | ||
| 18 | # The package version, both in 1.23 style *and* usable by MakeMaker: | |
| 19 | $VERSION = substr q$Revision: 1.2 $, 10; | |
| 20 | ||
| 21 | # Inheritance: | |
| 22 | @ISA = qw(IO::File); | |
| 23 | ||
| 24 | ||
| 25 | #------------------------------ | |
| 26 | # new ARGS... | |
| 27 | #------------------------------ | |
| 28 | # Class method, constructor. | |
| 29 | # Any arguments are sent to open(). | |
| 30 | # | |
| 31 | sub new { | |
| 32 | my $class = shift; | |
| 33 | my $self = $class->SUPER::new(); | |
| 34 | ${*$self}{'io_atomicfile_suffix'} = ''; | |
| 35 | $self->open(@_) if @_; | |
| 36 | $self; | |
| 37 | } | |
| 38 | ||
| 39 | #------------------------------ | |
| 40 | # DESTROY | |
| 41 | #------------------------------ | |
| 42 | # Destructor. | |
| 43 | # | |
| 44 | sub DESTROY { | |
| 45 | shift->close(1); ### like close, but raises fatal exception on failure | |
| 46 | } | |
| 47 | ||
| 48 | #------------------------------ | |
| 49 | # open PATH, MODE | |
| 50 | #------------------------------ | |
| 51 | # Class/instance method. | |
| 52 | # | |
| 53 | sub open { | |
| 54 | my ($self, $path, $mode) = @_; | |
| 55 | ref($self) or $self = $self->new; ### now we have an instance! | |
| 56 | ||
| 57 | ### Create tmp path, and remember this info: | |
| 58 | my $temp = "${path}..TMP" . ${*$self}{'io_atomicfile_suffix'}; | |
| 59 | ${*$self}{'io_atomicfile_temp'} = $temp; | |
| 60 | ${*$self}{'io_atomicfile_path'} = $path; | |
| 61 | ||
| 62 | ### Open the file! Returns filehandle on success, for use as a constructor: | |
| 63 | $self->SUPER::open($temp, $mode) ? $self : undef; | |
| 64 | } | |
| 65 | ||
| 66 | #------------------------------ | |
| 67 | # _closed [YESNO] | |
| 68 | #------------------------------ | |
| 69 | # Instance method, private. | |
| 70 | # Are we already closed? Argument sets new value, returns previous one. | |
| 71 | # | |
| 72 | sub _closed { | |
| 73 | my $self = shift; | |
| 74 | my $oldval = ${*$self}{'io_atomicfile_closed'}; | |
| 75 | ${*$self}{'io_atomicfile_closed'} = shift if @_; | |
| 76 | $oldval; | |
| 77 | } | |
| 78 | ||
| 79 | #------------------------------ | |
| 80 | # close | |
| 81 | #------------------------------ | |
| 82 | # Instance method. | |
| 83 | # Close the handle, and rename the temp file to its final name. | |
| 84 | # | |
| 85 | sub close { | |
| 86 | my ($self, $die) = @_; | |
| 87 | unless ($self->_closed(1)) { ### sentinel... | |
| 88 | $self->SUPER::close(); | |
| 89 | rename(${*$self}{'io_atomicfile_temp'}, | |
| 90 | ${*$self}{'io_atomicfile_path'}) | |
| 91 | or ($die ? die "close atomic file: $!\n" : return undef); | |
| 92 | } | |
| 93 | 1; | |
| 94 | } | |
| 95 | ||
| 96 | #------------------------------ | |
| 97 | # delete | |
| 98 | #------------------------------ | |
| 99 | # Instance method. | |
| 100 | # Close the handle, and delete the temp file. | |
| 101 | # | |
| 102 | sub delete { | |
| 103 | my $self = shift; | |
| 104 | unless ($self->_closed(1)) { ### sentinel... | |
| 105 | $self->SUPER::close(); | |
| 106 | return unlink(${*$self}{'io_atomicfile_temp'}); | |
| 107 | } | |
| 108 | 1; | |
| 109 | } | |
| 110 | ||
| 111 | #------------------------------ | |
| 112 | # detach | |
| 113 | #------------------------------ | |
| 114 | # Instance method. | |
| 115 | # Close the handle, but DO NOT delete the temp file. | |
| 116 | # | |
| 117 | sub detach { | |
| 118 | my $self = shift; | |
| 119 | $self->SUPER::close() unless ($self->_closed(1)); | |
| 120 | 1; | |
| 121 | } | |
| 122 | ||
| 123 | #------------------------------ | |
| 124 | 1; | |
| 125 | __END__ | |
| 126 | ||
| 127 | ||
| 128 | =head1 NAME | |
| 129 | ||
| 130 | IO::AtomicFile - write a file which is updated atomically | |
| 131 | ||
| 132 | ||
| 133 | =head1 SYNOPSIS | |
| 134 | ||
| 135 | use IO::AtomicFile; | |
| 136 | ||
| 137 | ### Write a temp file, and have it install itself when closed: | |
| 138 | my $FH = IO::AtomicFile->open("bar.dat", "w"); | |
| 139 | print $FH "Hello!\n"; | |
| 140 | $FH->close || die "couldn't install atomic file: $!"; | |
| 141 | ||
| 142 | ### Write a temp file, but delete it before it gets installed: | |
| 143 | my $FH = IO::AtomicFile->open("bar.dat", "w"); | |
| 144 | print $FH "Hello!\n"; | |
| 145 | $FH->delete; | |
| 146 | ||
| 147 | ### Write a temp file, but neither install it nor delete it: | |
| 148 | my $FH = IO::AtomicFile->open("bar.dat", "w"); | |
| 149 | print $FH "Hello!\n"; | |
| 150 | $FH->detach; | |
| 151 | ||
| 152 | ||
| 153 | =head1 DESCRIPTION | |
| 154 | ||
| 155 | This module is intended for people who need to update files | |
| 156 | reliably in the face of unexpected program termination. | |
| 157 | ||
| 158 | For example, you generally don't want to be halfway in the middle of | |
| 159 | writing I</etc/passwd> and have your program terminate! Even | |
| 160 | the act of writing a single scalar to a filehandle is I<not> atomic. | |
| 161 | ||
| 162 | But this module gives you true atomic updates, via rename(). | |
| 163 | When you open a file I</foo/bar.dat> via this module, you are I<actually> | |
| 164 | opening a temporary file I</foo/bar.dat..TMP>, and writing your | |
| 165 | output there. The act of closing this file (either explicitly | |
| 166 | via close(), or implicitly via the destruction of the object) | |
| 167 | will cause rename() to be called... therefore, from the point | |
| 168 | of view of the outside world, the file's contents are updated | |
| 169 | in a single time quantum. | |
| 170 | ||
| 171 | To ensure that problems do not go undetected, the "close" method | |
| 172 | done by the destructor will raise a fatal exception if the rename() | |
| 173 | fails. The explicit close() just returns undef. | |
| 174 | ||
| 175 | You can also decide at any point to trash the file you've been | |
| 176 | building. | |
| 177 | ||
| 178 | ||
| 179 | =head1 AUTHOR | |
| 180 | ||
| 181 | Eryq (F<eryq@zeegee.com>). | |
| 182 | President, ZeeGee Software Inc (F<http://www.zeegee.com>). | |
| 183 | ||
| 184 | ||
| 185 | =head1 REVISION | |
| 186 | ||
| 187 | $Revision: 1.2 $ | |
| 188 | ||
| 189 | =cut |
| 0 | package IO::InnerFile; | |
| 1 | ||
| 2 | =head1 NAME | |
| 3 | ||
| 4 | IO::InnerFile - define a file inside another file | |
| 5 | ||
| 6 | ||
| 7 | =head1 SYNOPSIS | |
| 8 | ||
| 9 | ||
| 10 | ### Read a subset of a file: | |
| 11 | $inner = IO::InnerFile->new($fh, $start, $length); | |
| 12 | while (<$inner>) { | |
| 13 | ... | |
| 14 | } | |
| 15 | ||
| 16 | ||
| 17 | =head1 DESCRIPTION | |
| 18 | ||
| 19 | If you have a filehandle that can seek() and tell(), then you | |
| 20 | can open an IO::InnerFile on a range of the underlying file. | |
| 21 | ||
| 22 | ||
| 23 | =head1 PUBLIC INTERFACE | |
| 24 | ||
| 25 | =over | |
| 26 | ||
| 27 | =cut | |
| 28 | ||
| 29 | use Symbol; | |
| 30 | ||
| 31 | # The package version, both in 1.23 style *and* usable by MakeMaker: | |
| 32 | $VERSION = substr q$Revision: 1.2 $, 10; | |
| 33 | ||
| 34 | #------------------------------ | |
| 35 | ||
| 36 | =item new FILEHANDLE, [START, [LENGTH]] | |
| 37 | ||
| 38 | I<Class method, constructor.> | |
| 39 | Create a new inner-file opened on the given FILEHANDLE, | |
| 40 | from bytes START to START+LENGTH. Both START and LENGTH | |
| 41 | default to 0; negative values are silently coerced to zero. | |
| 42 | ||
| 43 | Note that FILEHANDLE must be able to seek() and tell(), in addition | |
| 44 | to whatever other methods you may desire for reading it. | |
| 45 | ||
| 46 | =cut | |
| 47 | ||
| 48 | sub new { | |
| 49 | my ($class, $fh, $start, $lg) = @_; | |
| 50 | $start = 0 if (!$start or ($start < 0)); | |
| 51 | $lg = 0 if (!$lg or ($lg < 0)); | |
| 52 | ||
| 53 | ### Create the underlying "object": | |
| 54 | my $a = { | |
| 55 | FH => $fh, | |
| 56 | CRPOS => 0, | |
| 57 | START => $start, | |
| 58 | LG => $lg, | |
| 59 | }; | |
| 60 | ||
| 61 | ### Create a new filehandle tied to this object: | |
| 62 | $fh = gensym; | |
| 63 | tie(*$fh, $class, $a); | |
| 64 | return bless($fh, $class); | |
| 65 | } | |
| 66 | ||
| 67 | sub TIEHANDLE { | |
| 68 | my ($class, $data) = @_; | |
| 69 | return bless($data, $class); | |
| 70 | } | |
| 71 | ||
| 72 | sub DESTROY { | |
| 73 | my ($self) = @_; | |
| 74 | $self->close() if (ref($self) eq 'SCALAR'); | |
| 75 | } | |
| 76 | ||
| 77 | #------------------------------ | |
| 78 | ||
| 79 | =item set_length LENGTH | |
| 80 | ||
| 81 | =item get_length | |
| 82 | ||
| 83 | =item add_length NBYTES | |
| 84 | ||
| 85 | I<Instance methods.> | |
| 86 | Get/set the virtual length of the inner file. | |
| 87 | ||
| 88 | =cut | |
| 89 | ||
| 90 | sub set_length { tied(${$_[0]})->{LG} = $_[1]; } | |
| 91 | sub get_length { tied(${$_[0]})->{LG}; } | |
| 92 | sub add_length { tied(${$_[0]})->{LG} += $_[1]; } | |
| 93 | ||
| 94 | #------------------------------ | |
| 95 | ||
| 96 | =item set_start START | |
| 97 | ||
| 98 | =item get_start | |
| 99 | ||
| 100 | =item add_start NBYTES | |
| 101 | ||
| 102 | I<Instance methods.> | |
| 103 | Get/set the virtual start position of the inner file. | |
| 104 | ||
| 105 | =cut | |
| 106 | ||
| 107 | sub set_start { tied(${$_[0]})->{START} = $_[1]; } | |
| 108 | sub get_start { tied(${$_[0]})->{START}; } | |
| 109 | sub set_end { tied(${$_[0]})->{LG} = $_[1] - tied(${$_[0]})->{START}; } | |
| 110 | sub get_end { tied(${$_[0]})->{LG} + tied(${$_[0]})->{START}; } | |
| 111 | ||
| 112 | ||
| 113 | #------------------------------ | |
| 114 | ||
| 115 | =item binmode | |
| 116 | ||
| 117 | =item close | |
| 118 | ||
| 119 | =item flush | |
| 120 | ||
| 121 | =item getc | |
| 122 | ||
| 123 | =item getline | |
| 124 | ||
| 125 | =item print LIST | |
| 126 | ||
| 127 | =item printf LIST | |
| 128 | ||
| 129 | =item read BUF, NBYTES | |
| 130 | ||
| 131 | =item readline | |
| 132 | ||
| 133 | =item seek OFFFSET, WHENCE | |
| 134 | ||
| 135 | =item tell | |
| 136 | ||
| 137 | =item write ARGS... | |
| 138 | ||
| 139 | I<Instance methods.> | |
| 140 | Standard filehandle methods. | |
| 141 | ||
| 142 | =cut | |
| 143 | ||
| 144 | sub write { shift->WRITE(@_) } | |
| 145 | sub print { shift->PRINT(@_) } | |
| 146 | sub printf { shift->PRINTF(@_) } | |
| 147 | sub flush { 1; } | |
| 148 | sub binmode { 1; } | |
| 149 | sub getc { return GETC(tied(${$_[0]}) ); } | |
| 150 | sub read { return READ( tied(${$_[0]}), @_[1,2,3] ); } | |
| 151 | sub readline { return READLINE( tied(${$_[0]}) ); } | |
| 152 | sub getline { return READLINE( tied(${$_[0]}) ); } | |
| 153 | sub close { return CLOSE(tied(${$_[0]}) ); } | |
| 154 | ||
| 155 | sub seek { | |
| 156 | my ($self, $ofs, $whence) = @_; | |
| 157 | $self = tied( $$self ); | |
| 158 | ||
| 159 | $self->{CRPOS} = $ofs if ($whence == 0); | |
| 160 | $self->{CRPOS}+= $ofs if ($whence == 1); | |
| 161 | $self->{CRPOS} = $self->{LG} + $ofs if ($whence == 2); | |
| 162 | ||
| 163 | $self->{CRPOS} = 0 if ($self->{CRPOS} < 0); | |
| 164 | $self->{CRPOS} = $self->{LG} if ($self->{CRPOS} > $self->{LG}); | |
| 165 | } | |
| 166 | ||
| 167 | sub tell { | |
| 168 | return tied(${$_[0]})->{CRPOS}; | |
| 169 | } | |
| 170 | ||
| 171 | sub WRITE { | |
| 172 | die "inner files can only open for reading\n"; | |
| 173 | } | |
| 174 | ||
| 175 | sub PRINT { | |
| 176 | die "inner files can only open for reading\n"; | |
| 177 | } | |
| 178 | ||
| 179 | sub PRINTF { | |
| 180 | die "inner files can only open for reading\n"; | |
| 181 | } | |
| 182 | ||
| 183 | sub GETC { | |
| 184 | my ($self) = @_; | |
| 185 | return 0 if ($self->{CRPOS} >= $self->{LG}); | |
| 186 | ||
| 187 | my $data; | |
| 188 | ||
| 189 | ### Save and seek... | |
| 190 | my $old_pos = $self->{FH}->tell; | |
| 191 | $self->{FH}->seek($self->{CRPOS}+$self->{START}, 0); | |
| 192 | ||
| 193 | ### ...read... | |
| 194 | my $lg = $self->{FH}->read($data, 1); | |
| 195 | $self->{CRPOS} += $lg; | |
| 196 | ||
| 197 | ### ...and restore: | |
| 198 | $self->{FH}->seek($old_pos, 0); | |
| 199 | ||
| 200 | $self->{LG} = $self->{CRPOS} unless ($lg); | |
| 201 | return ($lg ? $data : undef); | |
| 202 | } | |
| 203 | ||
| 204 | sub READ { | |
| 205 | my ($self, $undefined, $lg, $ofs) = @_; | |
| 206 | $undefined = undef; | |
| 207 | ||
| 208 | return 0 if ($self->{CRPOS} >= $self->{LG}); | |
| 209 | $lg = $self->{LG} - $self->{CRPOS} if ($self->{CRPOS} + $lg > $self->{LG}); | |
| 210 | return 0 unless ($lg); | |
| 211 | ||
| 212 | ### Save and seek... | |
| 213 | my $old_pos = $self->{FH}->tell; | |
| 214 | $self->{FH}->seek($self->{CRPOS}+$self->{START}, 0); | |
| 215 | ||
| 216 | ### ...read... | |
| 217 | $lg = $self->{FH}->read($_[1], $lg, $_[3] ); | |
| 218 | $self->{CRPOS} += $lg; | |
| 219 | ||
| 220 | ### ...and restore: | |
| 221 | $self->{FH}->seek($old_pos, 0); | |
| 222 | ||
| 223 | $self->{LG} = $self->{CRPOS} unless ($lg); | |
| 224 | return $lg; | |
| 225 | } | |
| 226 | ||
| 227 | sub READLINE { | |
| 228 | my ($self) = @_; | |
| 229 | return undef if ($self->{CRPOS} >= $self->{LG}); | |
| 230 | ||
| 231 | ### Save and seek... | |
| 232 | my $old_pos = $self->{FH}->tell; | |
| 233 | $self->{FH}->seek($self->{CRPOS}+$self->{START}, 0); | |
| 234 | ||
| 235 | ### ...read... | |
| 236 | my $text = $self->{FH}->getline; | |
| 237 | ||
| 238 | ### ...and restore: | |
| 239 | $self->{FH}->seek($old_pos, 0); | |
| 240 | ||
| 241 | #### If we detected a new EOF ... | |
| 242 | unless (defined $text) { | |
| 243 | $self->{LG} = $self->{CRPOS}; | |
| 244 | return undef; | |
| 245 | } | |
| 246 | ||
| 247 | my $lg=length($text); | |
| 248 | ||
| 249 | $lg = $self->{LG} - $self->{CRPOS} if ($self->{CRPOS} + $lg > $self->{LG}); | |
| 250 | $self->{CRPOS} += $lg; | |
| 251 | ||
| 252 | return substr($text, 0,$lg); | |
| 253 | } | |
| 254 | ||
| 255 | sub CLOSE { %{$_[0]}=(); } | |
| 256 | ||
| 257 | ||
| 258 | ||
| 259 | 1; | |
| 260 | __END__ | |
| 261 | ||
| 262 | =back | |
| 263 | ||
| 264 | ||
| 265 | =head1 VERSION | |
| 266 | ||
| 267 | $Id: InnerFile.pm,v 1.2 2005/06/09 14:20:24 nj7w Exp $ | |
| 268 | ||
| 269 | ||
| 270 | =head1 AUTHOR | |
| 271 | ||
| 272 | Original version by Doru Petrescu (pdoru@kappa.ro). | |
| 273 | ||
| 274 | Documentation and current maintenance by Eryq (eryq@zeegee.com). | |
| 275 | ||
| 276 | =cut | |
| 277 | ||
| 278 |
| 0 | package IO::Lines; | |
| 1 | ||
| 2 | ||
| 3 | =head1 NAME | |
| 4 | ||
| 5 | IO::Lines - IO:: interface for reading/writing an array of lines | |
| 6 | ||
| 7 | ||
| 8 | =head1 SYNOPSIS | |
| 9 | ||
| 10 | use IO::Lines; | |
| 11 | ||
| 12 | ### See IO::ScalarArray for details | |
| 13 | ||
| 14 | ||
| 15 | =head1 DESCRIPTION | |
| 16 | ||
| 17 | This class implements objects which behave just like FileHandle | |
| 18 | (or IO::Handle) objects, except that you may use them to write to | |
| 19 | (or read from) an array of lines. They can be tiehandle'd as well. | |
| 20 | ||
| 21 | This is a subclass of L<IO::ScalarArray|IO::ScalarArray> | |
| 22 | in which the underlying | |
| 23 | array has its data stored in a line-oriented-format: that is, | |
| 24 | every element ends in a C<"\n">, with the possible exception of the | |
| 25 | final element. This makes C<getline()> I<much> more efficient; | |
| 26 | if you plan to do line-oriented reading/printing, you want this class. | |
| 27 | ||
| 28 | The C<print()> method will enforce this rule, so you can print | |
| 29 | arbitrary data to the line-array: it will break the data at | |
| 30 | newlines appropriately. | |
| 31 | ||
| 32 | See L<IO::ScalarArray> for full usage and warnings. | |
| 33 | ||
| 34 | =cut | |
| 35 | ||
| 36 | use Carp; | |
| 37 | use strict; | |
| 38 | use IO::ScalarArray; | |
| 39 | use vars qw($VERSION @ISA); | |
| 40 | ||
| 41 | # The package version, both in 1.23 style *and* usable by MakeMaker: | |
| 42 | $VERSION = substr q$Revision: 1.2 $, 10; | |
| 43 | ||
| 44 | # Inheritance: | |
| 45 | @ISA = qw(IO::ScalarArray); ### also gets us new_tie :-) | |
| 46 | ||
| 47 | ||
| 48 | #------------------------------ | |
| 49 | # | |
| 50 | # getline | |
| 51 | # | |
| 52 | # Instance method, override. | |
| 53 | # Return the next line, or undef on end of data. | |
| 54 | # Can safely be called in an array context. | |
| 55 | # Currently, lines are delimited by "\n". | |
| 56 | # | |
| 57 | sub getline { | |
| 58 | my $self = shift; | |
| 59 | ||
| 60 | if (!defined $/) { | |
| 61 | return join( '', $self->_getlines_for_newlines ); | |
| 62 | } | |
| 63 | elsif ($/ eq "\n") { | |
| 64 | if (!*$self->{Pos}) { ### full line... | |
| 65 | return *$self->{AR}[*$self->{Str}++]; | |
| 66 | } | |
| 67 | else { ### partial line... | |
| 68 | my $partial = substr(*$self->{AR}[*$self->{Str}++], *$self->{Pos}); | |
| 69 | *$self->{Pos} = 0; | |
| 70 | return $partial; | |
| 71 | } | |
| 72 | } | |
| 73 | else { | |
| 74 | croak 'unsupported $/: must be "\n" or undef'; | |
| 75 | } | |
| 76 | } | |
| 77 | ||
| 78 | #------------------------------ | |
| 79 | # | |
| 80 | # getlines | |
| 81 | # | |
| 82 | # Instance method, override. | |
| 83 | # Return an array comprised of the remaining lines, or () on end of data. | |
| 84 | # Must be called in an array context. | |
| 85 | # Currently, lines are delimited by "\n". | |
| 86 | # | |
| 87 | sub getlines { | |
| 88 | my $self = shift; | |
| 89 | wantarray or croak("can't call getlines in scalar context!"); | |
| 90 | ||
| 91 | if ((defined $/) and ($/ eq "\n")) { | |
| 92 | return $self->_getlines_for_newlines(@_); | |
| 93 | } | |
| 94 | else { ### slow but steady | |
| 95 | return $self->SUPER::getlines(@_); | |
| 96 | } | |
| 97 | } | |
| 98 | ||
| 99 | #------------------------------ | |
| 100 | # | |
| 101 | # _getlines_for_newlines | |
| 102 | # | |
| 103 | # Instance method, private. | |
| 104 | # If $/ is newline, do fast getlines. | |
| 105 | # This CAN NOT invoke getline! | |
| 106 | # | |
| 107 | sub _getlines_for_newlines { | |
| 108 | my $self = shift; | |
| 109 | my ($rArray, $Str, $Pos) = @{*$self}{ qw( AR Str Pos ) }; | |
| 110 | my @partial = (); | |
| 111 | ||
| 112 | if ($Pos) { ### partial line... | |
| 113 | @partial = (substr( $rArray->[ $Str++ ], $Pos )); | |
| 114 | *$self->{Pos} = 0; | |
| 115 | } | |
| 116 | *$self->{Str} = scalar @$rArray; ### about to exhaust @$rArray | |
| 117 | return (@partial, | |
| 118 | @$rArray[ $Str .. $#$rArray ]); ### remaining full lines... | |
| 119 | } | |
| 120 | ||
| 121 | #------------------------------ | |
| 122 | # | |
| 123 | # print ARGS... | |
| 124 | # | |
| 125 | # Instance method, override. | |
| 126 | # Print ARGS to the underlying line array. | |
| 127 | # | |
| 128 | sub print { | |
| 129 | my $self = shift; | |
| 130 | ### print STDERR "\n[[ARRAY WAS...\n", @{*$self->{AR}}, "<<EOF>>\n"; | |
| 131 | my @lines = split /^/, join('', @_); @lines or return 1; | |
| 132 | ||
| 133 | ### Did the previous print not end with a newline? | |
| 134 | ### If so, append first line: | |
| 135 | if (@{*$self->{AR}} and (*$self->{AR}[-1] !~ /\n\Z/)) { | |
| 136 | *$self->{AR}[-1] .= shift @lines; | |
| 137 | } | |
| 138 | push @{*$self->{AR}}, @lines; ### add the remainder | |
| 139 | ### print STDERR "\n[[ARRAY IS NOW...\n", @{*$self->{AR}}, "<<EOF>>\n"; | |
| 140 | 1; | |
| 141 | } | |
| 142 | ||
| 143 | #------------------------------ | |
| 144 | 1; | |
| 145 | ||
| 146 | __END__ | |
| 147 | ||
| 148 | ||
| 149 | =head1 VERSION | |
| 150 | ||
| 151 | $Id: Lines.pm,v 1.2 2005/06/09 14:20:24 nj7w Exp $ | |
| 152 | ||
| 153 | ||
| 154 | =head1 AUTHORS | |
| 155 | ||
| 156 | ||
| 157 | =head2 Principal author | |
| 158 | ||
| 159 | Eryq (F<eryq@zeegee.com>). | |
| 160 | President, ZeeGee Software Inc (F<http://www.zeegee.com>). | |
| 161 | ||
| 162 | ||
| 163 | =head2 Other contributors | |
| 164 | ||
| 165 | Thanks to the following individuals for their invaluable contributions | |
| 166 | (if I've forgotten or misspelled your name, please email me!): | |
| 167 | ||
| 168 | I<Morris M. Siegel,> | |
| 169 | for his $/ patch and the new C<getlines()>. | |
| 170 | ||
| 171 | I<Doug Wilson,> | |
| 172 | for the IO::Handle inheritance and automatic tie-ing. | |
| 173 | ||
| 174 | =cut | |
| 175 |
| 0 | package IO::Scalar; | |
| 1 | ||
| 2 | ||
| 3 | =head1 NAME | |
| 4 | ||
| 5 | IO::Scalar - IO:: interface for reading/writing a scalar | |
| 6 | ||
| 7 | ||
| 8 | =head1 SYNOPSIS | |
| 9 | ||
| 10 | Perform I/O on strings, using the basic OO interface... | |
| 11 | ||
| 12 | use 5.005; | |
| 13 | use IO::Scalar; | |
| 14 | $data = "My message:\n"; | |
| 15 | ||
| 16 | ### Open a handle on a string, and append to it: | |
| 17 | $SH = new IO::Scalar \$data; | |
| 18 | $SH->print("Hello"); | |
| 19 | $SH->print(", world!\nBye now!\n"); | |
| 20 | print "The string is now: ", $data, "\n"; | |
| 21 | ||
| 22 | ### Open a handle on a string, read it line-by-line, then close it: | |
| 23 | $SH = new IO::Scalar \$data; | |
| 24 | while (defined($_ = $SH->getline)) { | |
| 25 | print "Got line: $_"; | |
| 26 | } | |
| 27 | $SH->close; | |
| 28 | ||
| 29 | ### Open a handle on a string, and slurp in all the lines: | |
| 30 | $SH = new IO::Scalar \$data; | |
| 31 | print "All lines:\n", $SH->getlines; | |
| 32 | ||
| 33 | ### Get the current position (either of two ways): | |
| 34 | $pos = $SH->getpos; | |
| 35 | $offset = $SH->tell; | |
| 36 | ||
| 37 | ### Set the current position (either of two ways): | |
| 38 | $SH->setpos($pos); | |
| 39 | $SH->seek($offset, 0); | |
| 40 | ||
| 41 | ### Open an anonymous temporary scalar: | |
| 42 | $SH = new IO::Scalar; | |
| 43 | $SH->print("Hi there!"); | |
| 44 | print "I printed: ", ${$SH->sref}, "\n"; ### get at value | |
| 45 | ||
| 46 | ||
| 47 | Don't like OO for your I/O? No problem. | |
| 48 | Thanks to the magic of an invisible tie(), the following now | |
| 49 | works out of the box, just as it does with IO::Handle: | |
| 50 | ||
| 51 | use 5.005; | |
| 52 | use IO::Scalar; | |
| 53 | $data = "My message:\n"; | |
| 54 | ||
| 55 | ### Open a handle on a string, and append to it: | |
| 56 | $SH = new IO::Scalar \$data; | |
| 57 | print $SH "Hello"; | |
| 58 | print $SH ", world!\nBye now!\n"; | |
| 59 | print "The string is now: ", $data, "\n"; | |
| 60 | ||
| 61 | ### Open a handle on a string, read it line-by-line, then close it: | |
| 62 | $SH = new IO::Scalar \$data; | |
| 63 | while (<$SH>) { | |
| 64 | print "Got line: $_"; | |
| 65 | } | |
| 66 | close $SH; | |
| 67 | ||
| 68 | ### Open a handle on a string, and slurp in all the lines: | |
| 69 | $SH = new IO::Scalar \$data; | |
| 70 | print "All lines:\n", <$SH>; | |
| 71 | ||
| 72 | ### Get the current position (WARNING: requires 5.6): | |
| 73 | $offset = tell $SH; | |
| 74 | ||
| 75 | ### Set the current position (WARNING: requires 5.6): | |
| 76 | seek $SH, $offset, 0; | |
| 77 | ||
| 78 | ### Open an anonymous temporary scalar: | |
| 79 | $SH = new IO::Scalar; | |
| 80 | print $SH "Hi there!"; | |
| 81 | print "I printed: ", ${$SH->sref}, "\n"; ### get at value | |
| 82 | ||
| 83 | ||
| 84 | And for you folks with 1.x code out there: the old tie() style still works, | |
| 85 | though this is I<unnecessary and deprecated>: | |
| 86 | ||
| 87 | use IO::Scalar; | |
| 88 | ||
| 89 | ### Writing to a scalar... | |
| 90 | my $s; | |
| 91 | tie *OUT, 'IO::Scalar', \$s; | |
| 92 | print OUT "line 1\nline 2\n", "line 3\n"; | |
| 93 | print "String is now: $s\n" | |
| 94 | ||
| 95 | ### Reading and writing an anonymous scalar... | |
| 96 | tie *OUT, 'IO::Scalar'; | |
| 97 | print OUT "line 1\nline 2\n", "line 3\n"; | |
| 98 | tied(OUT)->seek(0,0); | |
| 99 | while (<OUT>) { | |
| 100 | print "Got line: ", $_; | |
| 101 | } | |
| 102 | ||
| 103 | ||
| 104 | Stringification works, too! | |
| 105 | ||
| 106 | my $SH = new IO::Scalar \$data; | |
| 107 | print $SH "Hello, "; | |
| 108 | print $SH "world!"; | |
| 109 | print "I printed: $SH\n"; | |
| 110 | ||
| 111 | ||
| 112 | ||
| 113 | =head1 DESCRIPTION | |
| 114 | ||
| 115 | This class is part of the IO::Stringy distribution; | |
| 116 | see L<IO::Stringy> for change log and general information. | |
| 117 | ||
| 118 | The IO::Scalar class implements objects which behave just like | |
| 119 | IO::Handle (or FileHandle) objects, except that you may use them | |
| 120 | to write to (or read from) scalars. These handles are | |
| 121 | automatically tiehandle'd (though please see L<"WARNINGS"> | |
| 122 | for information relevant to your Perl version). | |
| 123 | ||
| 124 | ||
| 125 | Basically, this: | |
| 126 | ||
| 127 | my $s; | |
| 128 | $SH = new IO::Scalar \$s; | |
| 129 | $SH->print("Hel", "lo, "); ### OO style | |
| 130 | $SH->print("world!\n"); ### ditto | |
| 131 | ||
| 132 | Or this: | |
| 133 | ||
| 134 | my $s; | |
| 135 | $SH = tie *OUT, 'IO::Scalar', \$s; | |
| 136 | print OUT "Hel", "lo, "; ### non-OO style | |
| 137 | print OUT "world!\n"; ### ditto | |
| 138 | ||
| 139 | Causes $s to be set to: | |
| 140 | ||
| 141 | "Hello, world!\n" | |
| 142 | ||
| 143 | ||
| 144 | =head1 PUBLIC INTERFACE | |
| 145 | ||
| 146 | =cut | |
| 147 | ||
| 148 | use Carp; | |
| 149 | use strict; | |
| 150 | use vars qw($VERSION @ISA); | |
| 151 | use IO::Handle; | |
| 152 | ||
| 153 | use 5.005; | |
| 154 | ||
| 155 | ### Stringification, courtesy of B. K. Oxley (binkley): :-) | |
| 156 | use overload '""' => sub { ${*{$_[0]}->{SR}} }; | |
| 157 | use overload 'bool' => sub { 1 }; ### have to do this, so object is true! | |
| 158 | ||
| 159 | ### The package version, both in 1.23 style *and* usable by MakeMaker: | |
| 160 | $VERSION = substr q$Revision: 1.2 $, 10; | |
| 161 | ||
| 162 | ### Inheritance: | |
| 163 | @ISA = qw(IO::Handle); | |
| 164 | ||
| 165 | ### This stuff should be got rid of ASAP. | |
| 166 | require IO::WrapTie and push @ISA, 'IO::WrapTie::Slave' if ($] >= 5.004); | |
| 167 | ||
| 168 | #============================== | |
| 169 | ||
| 170 | =head2 Construction | |
| 171 | ||
| 172 | =over 4 | |
| 173 | ||
| 174 | =cut | |
| 175 | ||
| 176 | #------------------------------ | |
| 177 | ||
| 178 | =item new [ARGS...] | |
| 179 | ||
| 180 | I<Class method.> | |
| 181 | Return a new, unattached scalar handle. | |
| 182 | If any arguments are given, they're sent to open(). | |
| 183 | ||
| 184 | =cut | |
| 185 | ||
| 186 | sub new { | |
| 187 | my $proto = shift; | |
| 188 | my $class = ref($proto) || $proto; | |
| 189 | my $self = bless \do { local *FH }, $class; | |
| 190 | tie *$self, $class, $self; | |
| 191 | $self->open(@_); ### open on anonymous by default | |
| 192 | $self; | |
| 193 | } | |
| 194 | sub DESTROY { | |
| 195 | shift->close; | |
| 196 | } | |
| 197 | ||
| 198 | #------------------------------ | |
| 199 | ||
| 200 | =item open [SCALARREF] | |
| 201 | ||
| 202 | I<Instance method.> | |
| 203 | Open the scalar handle on a new scalar, pointed to by SCALARREF. | |
| 204 | If no SCALARREF is given, a "private" scalar is created to hold | |
| 205 | the file data. | |
| 206 | ||
| 207 | Returns the self object on success, undefined on error. | |
| 208 | ||
| 209 | =cut | |
| 210 | ||
| 211 | sub open { | |
| 212 | my ($self, $sref) = @_; | |
| 213 | ||
| 214 | ### Sanity: | |
| 215 | defined($sref) or do {my $s = ''; $sref = \$s}; | |
| 216 | (ref($sref) eq "SCALAR") or croak "open() needs a ref to a scalar"; | |
| 217 | ||
| 218 | ### Setup: | |
| 219 | *$self->{Pos} = 0; ### seek position | |
| 220 | *$self->{SR} = $sref; ### scalar reference | |
| 221 | $self; | |
| 222 | } | |
| 223 | ||
| 224 | #------------------------------ | |
| 225 | ||
| 226 | =item opened | |
| 227 | ||
| 228 | I<Instance method.> | |
| 229 | Is the scalar handle opened on something? | |
| 230 | ||
| 231 | =cut | |
| 232 | ||
| 233 | sub opened { | |
| 234 | *{shift()}->{SR}; | |
| 235 | } | |
| 236 | ||
| 237 | #------------------------------ | |
| 238 | ||
| 239 | =item close | |
| 240 | ||
| 241 | I<Instance method.> | |
| 242 | Disassociate the scalar handle from its underlying scalar. | |
| 243 | Done automatically on destroy. | |
| 244 | ||
| 245 | =cut | |
| 246 | ||
| 247 | sub close { | |
| 248 | my $self = shift; | |
| 249 | %{*$self} = (); | |
| 250 | 1; | |
| 251 | } | |
| 252 | ||
| 253 | =back | |
| 254 | ||
| 255 | =cut | |
| 256 | ||
| 257 | ||
| 258 | ||
| 259 | #============================== | |
| 260 | ||
| 261 | =head2 Input and output | |
| 262 | ||
| 263 | =over 4 | |
| 264 | ||
| 265 | =cut | |
| 266 | ||
| 267 | ||
| 268 | #------------------------------ | |
| 269 | ||
| 270 | =item flush | |
| 271 | ||
| 272 | I<Instance method.> | |
| 273 | No-op, provided for OO compatibility. | |
| 274 | ||
| 275 | =cut | |
| 276 | ||
| 277 | sub flush {} | |
| 278 | ||
| 279 | #------------------------------ | |
| 280 | ||
| 281 | =item getc | |
| 282 | ||
| 283 | I<Instance method.> | |
| 284 | Return the next character, or undef if none remain. | |
| 285 | ||
| 286 | =cut | |
| 287 | ||
| 288 | sub getc { | |
| 289 | my $self = shift; | |
| 290 | ||
| 291 | ### Return undef right away if at EOF; else, move pos forward: | |
| 292 | return undef if $self->eof; | |
| 293 | substr(${*$self->{SR}}, *$self->{Pos}++, 1); | |
| 294 | } | |
| 295 | ||
| 296 | #------------------------------ | |
| 297 | ||
| 298 | =item getline | |
| 299 | ||
| 300 | I<Instance method.> | |
| 301 | Return the next line, or undef on end of string. | |
| 302 | Can safely be called in an array context. | |
| 303 | Currently, lines are delimited by "\n". | |
| 304 | ||
| 305 | =cut | |
| 306 | ||
| 307 | sub getline { | |
| 308 | my $self = shift; | |
| 309 | ||
| 310 | ### Return undef right away if at EOF: | |
| 311 | return undef if $self->eof; | |
| 312 | ||
| 313 | ### Get next line: | |
| 314 | my $sr = *$self->{SR}; | |
| 315 | my $i = *$self->{Pos}; ### Start matching at this point. | |
| 316 | ||
| 317 | ### Minimal impact implementation! | |
| 318 | ### We do the fast fast thing (no regexps) if using the | |
| 319 | ### classic input record separator. | |
| 320 | ||
| 321 | ### Case 1: $/ is undef: slurp all... | |
| 322 | if (!defined($/)) { | |
| 323 | *$self->{Pos} = length $$sr; | |
| 324 | return substr($$sr, $i); | |
| 325 | } | |
| 326 | ||
| 327 | ### Case 2: $/ is "\n": zoom zoom zoom... | |
| 328 | elsif ($/ eq "\012") { | |
| 329 | ||
| 330 | ### Seek ahead for "\n"... yes, this really is faster than regexps. | |
| 331 | my $len = length($$sr); | |
| 332 | for (; $i < $len; ++$i) { | |
| 333 | last if ord (substr ($$sr, $i, 1)) == 10; | |
| 334 | } | |
| 335 | ||
| 336 | ### Extract the line: | |
| 337 | my $line; | |
| 338 | if ($i < $len) { ### We found a "\n": | |
| 339 | $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos} + 1); | |
| 340 | *$self->{Pos} = $i+1; ### Remember where we finished up. | |
| 341 | } | |
| 342 | else { ### No "\n"; slurp the remainder: | |
| 343 | $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos}); | |
| 344 | *$self->{Pos} = $len; | |
| 345 | } | |
| 346 | return $line; | |
| 347 | } | |
| 348 | ||
| 349 | ### Case 3: $/ is ref to int. Do fixed-size records. | |
| 350 | ### (Thanks to Dominique Quatravaux.) | |
| 351 | elsif (ref($/)) { | |
| 352 | my $len = length($$sr); | |
| 353 | my $i = ${$/} + 0; | |
| 354 | my $line = substr ($$sr, *$self->{Pos}, $i); | |
| 355 | *$self->{Pos} += $i; | |
| 356 | *$self->{Pos} = $len if (*$self->{Pos} > $len); | |
| 357 | return $line; | |
| 358 | } | |
| 359 | ||
| 360 | ### Case 4: $/ is either "" (paragraphs) or something weird... | |
| 361 | ### This is Graham's general-purpose stuff, which might be | |
| 362 | ### a tad slower than Case 2 for typical data, because | |
| 363 | ### of the regexps. | |
| 364 | else { | |
| 365 | pos($$sr) = $i; | |
| 366 | ||
| 367 | ### If in paragraph mode, skip leading lines (and update i!): | |
| 368 | length($/) or | |
| 369 | (($$sr =~ m/\G\n*/g) and ($i = pos($$sr))); | |
| 370 | ||
| 371 | ### If we see the separator in the buffer ahead... | |
| 372 | if (length($/) | |
| 373 | ? $$sr =~ m,\Q$/\E,g ### (ordinary sep) TBD: precomp! | |
| 374 | : $$sr =~ m,\n\n,g ### (a paragraph) | |
| 375 | ) { | |
| 376 | *$self->{Pos} = pos $$sr; | |
| 377 | return substr($$sr, $i, *$self->{Pos}-$i); | |
| 378 | } | |
| 379 | ### Else if no separator remains, just slurp the rest: | |
| 380 | else { | |
| 381 | *$self->{Pos} = length $$sr; | |
| 382 | return substr($$sr, $i); | |
| 383 | } | |
| 384 | } | |
| 385 | } | |
| 386 | ||
| 387 | #------------------------------ | |
| 388 | ||
| 389 | =item getlines | |
| 390 | ||
| 391 | I<Instance method.> | |
| 392 | Get all remaining lines. | |
| 393 | It will croak() if accidentally called in a scalar context. | |
| 394 | ||
| 395 | =cut | |
| 396 | ||
| 397 | sub getlines { | |
| 398 | my $self = shift; | |
| 399 | wantarray or croak("can't call getlines in scalar context!"); | |
| 400 | my ($line, @lines); | |
| 401 | push @lines, $line while (defined($line = $self->getline)); | |
| 402 | @lines; | |
| 403 | } | |
| 404 | ||
| 405 | #------------------------------ | |
| 406 | ||
| 407 | =item print ARGS... | |
| 408 | ||
| 409 | I<Instance method.> | |
| 410 | Print ARGS to the underlying scalar. | |
| 411 | ||
| 412 | B<Warning:> this continues to always cause a seek to the end | |
| 413 | of the string, but if you perform seek()s and tell()s, it is | |
| 414 | still safer to explicitly seek-to-end before subsequent print()s. | |
| 415 | ||
| 416 | =cut | |
| 417 | ||
| 418 | sub print { | |
| 419 | my $self = shift; | |
| 420 | *$self->{Pos} = length(${*$self->{SR}} .= join('', @_)); | |
| 421 | 1; | |
| 422 | } | |
| 423 | sub _unsafe_print { | |
| 424 | my $self = shift; | |
| 425 | my $append = join('', @_); | |
| 426 | ${*$self->{SR}} .= $append; | |
| 427 | *$self->{Pos} += length($append); | |
| 428 | 1; | |
| 429 | } | |
| 430 | sub _old_print { | |
| 431 | my $self = shift; | |
| 432 | ${*$self->{SR}} .= join('', @_); | |
| 433 | *$self->{Pos} = length(${*$self->{SR}}); | |
| 434 | 1; | |
| 435 | } | |
| 436 | ||
| 437 | ||
| 438 | #------------------------------ | |
| 439 | ||
| 440 | =item read BUF, NBYTES, [OFFSET] | |
| 441 | ||
| 442 | I<Instance method.> | |
| 443 | Read some bytes from the scalar. | |
| 444 | Returns the number of bytes actually read, 0 on end-of-file, undef on error. | |
| 445 | ||
| 446 | =cut | |
| 447 | ||
| 448 | sub read { | |
| 449 | my $self = $_[0]; | |
| 450 | my $n = $_[2]; | |
| 451 | my $off = $_[3] || 0; | |
| 452 | ||
| 453 | my $read = substr(${*$self->{SR}}, *$self->{Pos}, $n); | |
| 454 | $n = length($read); | |
| 455 | *$self->{Pos} += $n; | |
| 456 | ($off ? substr($_[1], $off) : $_[1]) = $read; | |
| 457 | return $n; | |
| 458 | } | |
| 459 | ||
| 460 | #------------------------------ | |
| 461 | ||
| 462 | =item write BUF, NBYTES, [OFFSET] | |
| 463 | ||
| 464 | I<Instance method.> | |
| 465 | Write some bytes to the scalar. | |
| 466 | ||
| 467 | =cut | |
| 468 | ||
| 469 | sub write { | |
| 470 | my $self = $_[0]; | |
| 471 | my $n = $_[2]; | |
| 472 | my $off = $_[3] || 0; | |
| 473 | ||
| 474 | my $data = substr($_[1], $off, $n); | |
| 475 | $n = length($data); | |
| 476 | $self->print($data); | |
| 477 | return $n; | |
| 478 | } | |
| 479 | ||
| 480 | #------------------------------ | |
| 481 | ||
| 482 | =item sysread BUF, LEN, [OFFSET] | |
| 483 | ||
| 484 | I<Instance method.> | |
| 485 | Read some bytes from the scalar. | |
| 486 | Returns the number of bytes actually read, 0 on end-of-file, undef on error. | |
| 487 | ||
| 488 | =cut | |
| 489 | ||
| 490 | sub sysread { | |
| 491 | my $self = shift; | |
| 492 | $self->read(@_); | |
| 493 | } | |
| 494 | ||
| 495 | #------------------------------ | |
| 496 | ||
| 497 | =item syswrite BUF, NBYTES, [OFFSET] | |
| 498 | ||
| 499 | I<Instance method.> | |
| 500 | Write some bytes to the scalar. | |
| 501 | ||
| 502 | =cut | |
| 503 | ||
| 504 | sub syswrite { | |
| 505 | my $self = shift; | |
| 506 | $self->write(@_); | |
| 507 | } | |
| 508 | ||
| 509 | =back | |
| 510 | ||
| 511 | =cut | |
| 512 | ||
| 513 | ||
| 514 | #============================== | |
| 515 | ||
| 516 | =head2 Seeking/telling and other attributes | |
| 517 | ||
| 518 | =over 4 | |
| 519 | ||
| 520 | =cut | |
| 521 | ||
| 522 | ||
| 523 | #------------------------------ | |
| 524 | ||
| 525 | =item autoflush | |
| 526 | ||
| 527 | I<Instance method.> | |
| 528 | No-op, provided for OO compatibility. | |
| 529 | ||
| 530 | =cut | |
| 531 | ||
| 532 | sub autoflush {} | |
| 533 | ||
| 534 | #------------------------------ | |
| 535 | ||
| 536 | =item binmode | |
| 537 | ||
| 538 | I<Instance method.> | |
| 539 | No-op, provided for OO compatibility. | |
| 540 | ||
| 541 | =cut | |
| 542 | ||
| 543 | sub binmode {} | |
| 544 | ||
| 545 | #------------------------------ | |
| 546 | ||
| 547 | =item clearerr | |
| 548 | ||
| 549 | I<Instance method.> Clear the error and EOF flags. A no-op. | |
| 550 | ||
| 551 | =cut | |
| 552 | ||
| 553 | sub clearerr { 1 } | |
| 554 | ||
| 555 | #------------------------------ | |
| 556 | ||
| 557 | =item eof | |
| 558 | ||
| 559 | I<Instance method.> Are we at end of file? | |
| 560 | ||
| 561 | =cut | |
| 562 | ||
| 563 | sub eof { | |
| 564 | my $self = shift; | |
| 565 | (*$self->{Pos} >= length(${*$self->{SR}})); | |
| 566 | } | |
| 567 | ||
| 568 | #------------------------------ | |
| 569 | ||
| 570 | =item seek OFFSET, WHENCE | |
| 571 | ||
| 572 | I<Instance method.> Seek to a given position in the stream. | |
| 573 | ||
| 574 | =cut | |
| 575 | ||
| 576 | sub seek { | |
| 577 | my ($self, $pos, $whence) = @_; | |
| 578 | my $eofpos = length(${*$self->{SR}}); | |
| 579 | ||
| 580 | ### Seek: | |
| 581 | if ($whence == 0) { *$self->{Pos} = $pos } ### SEEK_SET | |
| 582 | elsif ($whence == 1) { *$self->{Pos} += $pos } ### SEEK_CUR | |
| 583 | elsif ($whence == 2) { *$self->{Pos} = $eofpos + $pos} ### SEEK_END | |
| 584 | else { croak "bad seek whence ($whence)" } | |
| 585 | ||
| 586 | ### Fixup: | |
| 587 | if (*$self->{Pos} < 0) { *$self->{Pos} = 0 } | |
| 588 | if (*$self->{Pos} > $eofpos) { *$self->{Pos} = $eofpos } | |
| 589 | 1; | |
| 590 | } | |
| 591 | ||
| 592 | #------------------------------ | |
| 593 | ||
| 594 | =item sysseek OFFSET, WHENCE | |
| 595 | ||
| 596 | I<Instance method.> Identical to C<seek OFFSET, WHENCE>, I<q.v.> | |
| 597 | ||
| 598 | =cut | |
| 599 | ||
| 600 | sub sysseek { | |
| 601 | my $self = shift; | |
| 602 | $self->seek (@_); | |
| 603 | } | |
| 604 | ||
| 605 | #------------------------------ | |
| 606 | ||
| 607 | =item tell | |
| 608 | ||
| 609 | I<Instance method.> | |
| 610 | Return the current position in the stream, as a numeric offset. | |
| 611 | ||
| 612 | =cut | |
| 613 | ||
| 614 | sub tell { *{shift()}->{Pos} } | |
| 615 | ||
| 616 | #------------------------------ | |
| 617 | # | |
| 618 | # use_RS [YESNO] | |
| 619 | # | |
| 620 | # I<Instance method.> | |
| 621 | # Obey the curent setting of $/, like IO::Handle does? | |
| 622 | # Default is false in 1.x, but cold-welded true in 2.x and later. | |
| 623 | # | |
| 624 | sub use_RS { | |
| 625 | my ($self, $yesno) = @_; | |
| 626 | carp "use_RS is deprecated and ignored; \$/ is always consulted\n"; | |
| 627 | } | |
| 628 | ||
| 629 | #------------------------------ | |
| 630 | ||
| 631 | =item setpos POS | |
| 632 | ||
| 633 | I<Instance method.> | |
| 634 | Set the current position, using the opaque value returned by C<getpos()>. | |
| 635 | ||
| 636 | =cut | |
| 637 | ||
| 638 | sub setpos { shift->seek($_[0],0) } | |
| 639 | ||
| 640 | #------------------------------ | |
| 641 | ||
| 642 | =item getpos | |
| 643 | ||
| 644 | I<Instance method.> | |
| 645 | Return the current position in the string, as an opaque object. | |
| 646 | ||
| 647 | =cut | |
| 648 | ||
| 649 | *getpos = \&tell; | |
| 650 | ||
| 651 | ||
| 652 | #------------------------------ | |
| 653 | ||
| 654 | =item sref | |
| 655 | ||
| 656 | I<Instance method.> | |
| 657 | Return a reference to the underlying scalar. | |
| 658 | ||
| 659 | =cut | |
| 660 | ||
| 661 | sub sref { *{shift()}->{SR} } | |
| 662 | ||
| 663 | ||
| 664 | #------------------------------ | |
| 665 | # Tied handle methods... | |
| 666 | #------------------------------ | |
| 667 | ||
| 668 | # Conventional tiehandle interface: | |
| 669 | sub TIEHANDLE { | |
| 670 | ((defined($_[1]) && UNIVERSAL::isa($_[1], "IO::Scalar")) | |
| 671 | ? $_[1] | |
| 672 | : shift->new(@_)); | |
| 673 | } | |
| 674 | sub GETC { shift->getc(@_) } | |
| 675 | sub PRINT { shift->print(@_) } | |
| 676 | sub PRINTF { shift->print(sprintf(shift, @_)) } | |
| 677 | sub READ { shift->read(@_) } | |
| 678 | sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) } | |
| 679 | sub WRITE { shift->write(@_); } | |
| 680 | sub CLOSE { shift->close(@_); } | |
| 681 | sub SEEK { shift->seek(@_); } | |
| 682 | sub TELL { shift->tell(@_); } | |
| 683 | sub EOF { shift->eof(@_); } | |
| 684 | ||
| 685 | #------------------------------------------------------------ | |
| 686 | ||
| 687 | 1; | |
| 688 | ||
| 689 | __END__ | |
| 690 | ||
| 691 | ||
| 692 | ||
| 693 | =back | |
| 694 | ||
| 695 | =cut | |
| 696 | ||
| 697 | ||
| 698 | =head1 WARNINGS | |
| 699 | ||
| 700 | Perl's TIEHANDLE spec was incomplete prior to 5.005_57; | |
| 701 | it was missing support for C<seek()>, C<tell()>, and C<eof()>. | |
| 702 | Attempting to use these functions with an IO::Scalar will not work | |
| 703 | prior to 5.005_57. IO::Scalar will not have the relevant methods | |
| 704 | invoked; and even worse, this kind of bug can lie dormant for a while. | |
| 705 | If you turn warnings on (via C<$^W> or C<perl -w>), | |
| 706 | and you see something like this... | |
| 707 | ||
| 708 | attempt to seek on unopened filehandle | |
| 709 | ||
| 710 | ...then you are probably trying to use one of these functions | |
| 711 | on an IO::Scalar with an old Perl. The remedy is to simply | |
| 712 | use the OO version; e.g.: | |
| 713 | ||
| 714 | $SH->seek(0,0); ### GOOD: will work on any 5.005 | |
| 715 | seek($SH,0,0); ### WARNING: will only work on 5.005_57 and beyond | |
| 716 | ||
| 717 | ||
| 718 | =head1 VERSION | |
| 719 | ||
| 720 | $Id: Scalar.pm,v 1.2 2005/06/09 14:20:24 nj7w Exp $ | |
| 721 | ||
| 722 | ||
| 723 | =head1 AUTHORS | |
| 724 | ||
| 725 | ||
| 726 | =head2 Principal author | |
| 727 | ||
| 728 | Eryq (F<eryq@zeegee.com>). | |
| 729 | President, ZeeGee Software Inc (F<http://www.zeegee.com>). | |
| 730 | ||
| 731 | ||
| 732 | =head2 Other contributors | |
| 733 | ||
| 734 | The full set of contributors always includes the folks mentioned | |
| 735 | in L<IO::Stringy/"CHANGE LOG">. But just the same, special | |
| 736 | thanks to the following individuals for their invaluable contributions | |
| 737 | (if I've forgotten or misspelled your name, please email me!): | |
| 738 | ||
| 739 | I<Andy Glew,> | |
| 740 | for contributing C<getc()>. | |
| 741 | ||
| 742 | I<Brandon Browning,> | |
| 743 | for suggesting C<opened()>. | |
| 744 | ||
| 745 | I<David Richter,> | |
| 746 | for finding and fixing the bug in C<PRINTF()>. | |
| 747 | ||
| 748 | I<Eric L. Brine,> | |
| 749 | for his offset-using read() and write() implementations. | |
| 750 | ||
| 751 | I<Richard Jones,> | |
| 752 | for his patches to massively improve the performance of C<getline()> | |
| 753 | and add C<sysread> and C<syswrite>. | |
| 754 | ||
| 755 | I<B. K. Oxley (binkley),> | |
| 756 | for stringification and inheritance improvements, | |
| 757 | and sundry good ideas. | |
| 758 | ||
| 759 | I<Doug Wilson,> | |
| 760 | for the IO::Handle inheritance and automatic tie-ing. | |
| 761 | ||
| 762 | ||
| 763 | =head1 SEE ALSO | |
| 764 | ||
| 765 | L<IO::String>, which is quite similar but which was designed | |
| 766 | more-recently and with an IO::Handle-like interface in mind, | |
| 767 | so you could mix OO- and native-filehandle usage without using tied(). | |
| 768 | ||
| 769 | I<Note:> as of version 2.x, these classes all work like | |
| 770 | their IO::Handle counterparts, so we have comparable | |
| 771 | functionality to IO::String. | |
| 772 | ||
| 773 | =cut | |
| 774 |
| 0 | <HTML> | |
| 1 | <HEAD> | |
| 2 | <TITLE>IO::Scalar</TITLE> | |
| 3 | </HEAD> | |
| 4 | <BODY | |
| 5 | bgcolor="#FFFFFF" link="#CC3366" vlink="#993366" alink="#FF6666"> | |
| 6 | <FONT FACE="sans-serif" SIZE=-1><A HREF="http://www.zeegee.com" TARGET="_top"><IMG SRC="icons/zeegee.gif" ALT="ZeeGee Software" ALIGN="RIGHT" BORDER="0"></A><A NAME="__TOP__"><H1>IO::Scalar</H1> | |
| 7 | </A><UL> | |
| 8 | <LI> <A HREF="#NAME">NAME</A> | |
| 9 | <LI> <A HREF="#SYNOPSIS">SYNOPSIS</A> | |
| 10 | <LI> <A HREF="#DESCRIPTION">DESCRIPTION</A> | |
| 11 | <LI> <A HREF="#PUBLIC_INTERFACE">PUBLIC INTERFACE</A> | |
| 12 | <UL> | |
| 13 | <LI> <A HREF="#Construction">Construction</A> | |
| 14 | <LI> <A HREF="#Input_and_output">Input and output</A> | |
| 15 | <LI> <A HREF="#Seeking_telling_and_other_attributes">Seeking/telling and other attributes</A> | |
| 16 | </UL> | |
| 17 | <LI> <A HREF="#WARNINGS">WARNINGS</A> | |
| 18 | <LI> <A HREF="#VERSION">VERSION</A> | |
| 19 | <LI> <A HREF="#AUTHORS">AUTHORS</A> | |
| 20 | <UL> | |
| 21 | <LI> <A HREF="#Principal_author">Principal author</A> | |
| 22 | <LI> <A HREF="#Other_contributors">Other contributors</A> | |
| 23 | </UL> | |
| 24 | <LI> <A HREF="#SEE_ALSO">SEE ALSO</A> | |
| 25 | </UL> | |
| 26 | </A> | |
| 27 | ||
| 28 | <P><HR> | |
| 29 | <A NAME="NAME"><H2><A HREF="#__TOP__"><IMG SRC="icons/h1bullet.gif" ALT="Top" BORDER="0"></A> NAME</H2></A> | |
| 30 | ||
| 31 | ||
| 32 | <P>IO::Scalar - IO:: interface for reading/writing a scalar | |
| 33 | ||
| 34 | ||
| 35 | ||
| 36 | <P><HR> | |
| 37 | <A NAME="SYNOPSIS"><H2><A HREF="#__TOP__"><IMG SRC="icons/h1bullet.gif" ALT="Top" BORDER="0"></A> SYNOPSIS</H2></A> | |
| 38 | ||
| 39 | ||
| 40 | <P>Perform I/O on strings, using the basic OO interface... | |
| 41 | ||
| 42 | <FONT SIZE=3 FACE="courier"><PRE> | |
| 43 | use 5.005; | |
| 44 | use IO::Scalar; | |
| 45 | $data = "My message:\n"; | |
| 46 | </PRE></FONT> | |
| 47 | <FONT SIZE=3 FACE="courier"><PRE> | |
| 48 | ### Open a handle on a string, and append to it: | |
| 49 | $SH = new IO::Scalar \$data; | |
| 50 | $SH->print("Hello"); | |
| 51 | $SH->print(", world!\nBye now!\n"); | |
| 52 | print "The string is now: ", $data, "\n"; | |
| 53 | </PRE></FONT> | |
| 54 | <FONT SIZE=3 FACE="courier"><PRE> | |
| 55 | ### Open a handle on a string, read it line-by-line, then close it: | |
| 56 | $SH = new IO::Scalar \$data; | |
| 57 | while (defined($_ = $SH->getline)) { | |
| 58 | print "Got line: $_"; | |
| 59 | } | |
| 60 | $SH->close; | |
| 61 | </PRE></FONT> | |
| 62 | <FONT SIZE=3 FACE="courier"><PRE> | |
| 63 | ### Open a handle on a string, and slurp in all the lines: | |
| 64 | $SH = new IO::Scalar \$data; | |
| 65 | print "All lines:\n", $SH->getlines; | |
| 66 | </PRE></FONT> | |
| 67 | <FONT SIZE=3 FACE="courier"><PRE> | |
| 68 | ### Get the current position (either of two ways): | |
| 69 | $pos = $SH->getpos; | |
| 70 | $offset = $SH->tell; | |
| 71 | </PRE></FONT> | |
| 72 | <FONT SIZE=3 FACE="courier"><PRE> | |
| 73 | ### Set the current position (either of two ways): | |
| 74 | $SH->setpos($pos); | |
| 75 | $SH->seek($offset, 0); | |
| 76 | </PRE></FONT> | |
| 77 | <FONT SIZE=3 FACE="courier"><PRE> | |
| 78 | ### Open an anonymous temporary scalar: | |
| 79 | $SH = new IO::Scalar; | |
| 80 | $SH->print("Hi there!"); | |
| 81 | print "I printed: ", ${$SH->sref}, "\n"; ### get at value | |
| 82 | </PRE></FONT> | |
| 83 | ||
| 84 | <P>Don't like OO for your I/O? No problem. | |
| 85 | Thanks to the magic of an invisible tie(), the following now | |
| 86 | works out of the box, just as it does with IO::Handle: | |
| 87 | ||
| 88 | <FONT SIZE=3 FACE="courier"><PRE> | |
| 89 | use 5.005; | |
| 90 | use IO::Scalar; | |
| 91 | $data = "My message:\n"; | |
| 92 | ||
| 93 | ### Open a handle on a string, and append to it: | |
| 94 | $SH = new IO::Scalar \$data; | |
| 95 | print $SH "Hello"; | |
| 96 | print $SH ", world!\nBye now!\n"; | |
| 97 | print "The string is now: ", $data, "\n"; | |
| 98 | </PRE></FONT> | |
| 99 | <FONT SIZE=3 FACE="courier"><PRE> | |
| 100 | ### Open a handle on a string, read it line-by-line, then close it: | |
| 101 | $SH = new IO::Scalar \$data; | |
| 102 | while (<$SH>) { | |
| 103 | print "Got line: $_"; | |
| 104 | } | |
| 105 | close $SH; | |
| 106 | </PRE></FONT> | |
| 107 | <FONT SIZE=3 FACE="courier"><PRE> | |
| 108 | ### Open a handle on a string, and slurp in all the lines: | |
| 109 | $SH = new IO::Scalar \$data; | |
| 110 | print "All lines:\n", <$SH>; | |
| 111 | </PRE></FONT> | |
| 112 | <FONT SIZE=3 FACE="courier"><PRE> | |
| 113 | ### Get the current position (WARNING: requires 5.6): | |
| 114 | $offset = tell $SH; | |
| 115 | </PRE></FONT> | |
| 116 | <FONT SIZE=3 FACE="courier"><PRE> | |
| 117 | ### Set the current position (WARNING: requires 5.6): | |
| 118 | seek $SH, $offset, 0; | |
| 119 | </PRE></FONT> | |
| 120 | <FONT SIZE=3 FACE="courier"><PRE> | |
| 121 | ### Open an anonymous temporary scalar: | |
| 122 | $SH = new IO::Scalar; | |
| 123 | print $SH "Hi there!"; | |
| 124 | print "I printed: ", ${$SH->sref}, "\n"; ### get at value | |
| 125 | </PRE></FONT> | |
| 126 | ||
| 127 | <P>And for you folks with 1.x code out there: the old tie() style still works, | |
| 128 | though this is <I>unnecessary and deprecated</I>: | |
| 129 | ||
| 130 | <FONT SIZE=3 FACE="courier"><PRE> | |
| 131 | use IO::Scalar; | |
| 132 | </PRE></FONT> | |
| 133 | <FONT SIZE=3 FACE="courier"><PRE> | |
| 134 | ### Writing to a scalar... | |
| 135 | my $s; | |
| 136 | tie *OUT, 'IO::Scalar', \$s; | |
| 137 | print OUT "line 1\nline 2\n", "line 3\n"; | |
| 138 | print "String is now: $s\n" | |
| 139 | </PRE></FONT> | |
| 140 | <FONT SIZE=3 FACE="courier"><PRE> | |
| 141 | ### Reading and writing an anonymous scalar... | |
| 142 | tie *OUT, 'IO::Scalar'; | |
| 143 | print OUT "line 1\nline 2\n", "line 3\n"; | |
| 144 | tied(OUT)->seek(0,0); | |
| 145 | while (<OUT>) { | |
| 146 | print "Got line: ", $_; | |
| 147 | } | |
| 148 | </PRE></FONT> | |
| 149 | ||
| 150 | <P>Stringification works, too! | |
| 151 | ||
| 152 | <FONT SIZE=3 FACE="courier"><PRE> | |
| 153 | my $SH = new IO::Scalar \$data; | |
| 154 | print $SH "Hello, "; | |
| 155 | print $SH "world!"; | |
| 156 | print "I printed: $SH\n"; | |
| 157 | </PRE></FONT> | |
| 158 | ||
| 159 | ||
| 160 | <P><HR> | |
| 161 | <A NAME="DESCRIPTION"><H2><A HREF="#__TOP__"><IMG SRC="icons/h1bullet.gif" ALT="Top" BORDER="0"></A> DESCRIPTION</H2></A> | |
| 162 | ||
| 163 | ||
| 164 | <P>This class is part of the IO::Stringy distribution; | |
| 165 | see <A HREF="IO/Stringy.pm.html">IO::Stringy</A> for change log and general information. | |
| 166 | ||
| 167 | ||
| 168 | <P>The IO::Scalar class implements objects which behave just like | |
| 169 | IO::Handle (or FileHandle) objects, except that you may use them | |
| 170 | to write to (or read from) scalars. These handles are | |
| 171 | automatically tiehandle'd (though please see <A HREF="#WARNINGS">WARNINGS</A> | |
| 172 | for information relevant to your Perl version). | |
| 173 | ||
| 174 | ||
| 175 | <P>Basically, this: | |
| 176 | ||
| 177 | <FONT SIZE=3 FACE="courier"><PRE> | |
| 178 | my $s; | |
| 179 | $SH = new IO::Scalar \$s; | |
| 180 | $SH->print("Hel", "lo, "); ### OO style | |
| 181 | $SH->print("world!\n"); ### ditto | |
| 182 | </PRE></FONT> | |
| 183 | ||
| 184 | <P>Or this: | |
| 185 | ||
| 186 | <FONT SIZE=3 FACE="courier"><PRE> | |
| 187 | my $s; | |
| 188 | $SH = tie *OUT, 'IO::Scalar', \$s; | |
| 189 | print OUT "Hel", "lo, "; ### non-OO style | |
| 190 | print OUT "world!\n"; ### ditto | |
| 191 | </PRE></FONT> | |
| 192 | ||
| 193 | <P>Causes $s to be set to: | |
| 194 | ||
| 195 | <FONT SIZE=3 FACE="courier"><PRE> | |
| 196 | "Hello, world!\n" | |
| 197 | </PRE></FONT> | |
| 198 | ||
| 199 | ||
| 200 | <P><HR> | |
| 201 | <A NAME="PUBLIC_INTERFACE"><H2><A HREF="#__TOP__"><IMG SRC="icons/h1bullet.gif" ALT="Top" BORDER="0"></A> PUBLIC INTERFACE</H2></A> | |
| 202 | ||
| 203 | ||
| 204 | ||
| 205 | <P><HR> | |
| 206 | <A NAME="Construction"><H3><A HREF="#__TOP__"><IMG SRC="icons/h2bullet.gif" ALT="Top" BORDER="0"></A> Construction</H3></A> | |
| 207 | ||
| 208 | ||
| 209 | ||
| 210 | <DL> | |
| 211 | <P><DT><B><A NAME="item:new">new [ARGS...]</A></B></DT> | |
| 212 | <DD> | |
| 213 | <I>Class method.</I> | |
| 214 | Return a new, unattached scalar handle. | |
| 215 | If any arguments are given, they're sent to open(). | |
| 216 | ||
| 217 | <P><DT><B><A NAME="item:open">open [SCALARREF]</A></B></DT> | |
| 218 | <DD> | |
| 219 | <I>Instance method.</I> | |
| 220 | Open the scalar handle on a new scalar, pointed to by SCALARREF. | |
| 221 | If no SCALARREF is given, a "private" scalar is created to hold | |
| 222 | the file data. | |
| 223 | ||
| 224 | ||
| 225 | <P>Returns the self object on success, undefined on error. | |
| 226 | ||
| 227 | <P><DT><B><A NAME="item:opened">opened</A></B></DT> | |
| 228 | <DD> | |
| 229 | <I>Instance method.</I> | |
| 230 | Is the scalar handle opened on something? | |
| 231 | ||
| 232 | <P><DT><B><A NAME="item:close">close</A></B></DT> | |
| 233 | <DD> | |
| 234 | <I>Instance method.</I> | |
| 235 | Disassociate the scalar handle from its underlying scalar. | |
| 236 | Done automatically on destroy. | |
| 237 | ||
| 238 | </DL> | |
| 239 | ||
| 240 | ||
| 241 | ||
| 242 | <P><HR> | |
| 243 | <A NAME="Input_and_output"><H3><A HREF="#__TOP__"><IMG SRC="icons/h2bullet.gif" ALT="Top" BORDER="0"></A> Input and output</H3></A> | |
| 244 | ||
| 245 | ||
| 246 | ||
| 247 | <DL> | |
| 248 | <P><DT><B><A NAME="item:flush">flush</A></B></DT> | |
| 249 | <DD> | |
| 250 | <I>Instance method.</I> | |
| 251 | No-op, provided for OO compatibility. | |
| 252 | ||
| 253 | <P><DT><B><A NAME="item:getc">getc</A></B></DT> | |
| 254 | <DD> | |
| 255 | <I>Instance method.</I> | |
| 256 | Return the next character, or undef if none remain. | |
| 257 | ||
| 258 | <P><DT><B><A NAME="item:getline">getline</A></B></DT> | |
| 259 | <DD> | |
| 260 | <I>Instance method.</I> | |
| 261 | Return the next line, or undef on end of string. | |
| 262 | Can safely be called in an array context. | |
| 263 | Currently, lines are delimited by "\n". | |
| 264 | ||
| 265 | <P><DT><B><A NAME="item:getlines">getlines</A></B></DT> | |
| 266 | <DD> | |
| 267 | <I>Instance method.</I> | |
| 268 | Get all remaining lines. | |
| 269 | It will croak() if accidentally called in a scalar context. | |
| 270 | ||
| 271 | <P><DT><B><A NAME="item:print">print ARGS...</A></B></DT> | |
| 272 | <DD> | |
| 273 | <I>Instance method.</I> | |
| 274 | Print ARGS to the underlying scalar. | |
| 275 | ||
| 276 | ||
| 277 | <P><B>Warning:</B> this continues to always cause a seek to the end | |
| 278 | of the string, but if you perform seek()s and tell()s, it is | |
| 279 | still safer to explicitly seek-to-end before subsequent print()s. | |
| 280 | ||
| 281 | <P><DT><B><A NAME="item:read">read BUF, NBYTES, [OFFSET]</A></B></DT> | |
| 282 | <DD> | |
| 283 | <I>Instance method.</I> | |
| 284 | Read some bytes from the scalar. | |
| 285 | Returns the number of bytes actually read, 0 on end-of-file, undef on error. | |
| 286 | ||
| 287 | <P><DT><B><A NAME="item:write">write BUF, NBYTES, [OFFSET]</A></B></DT> | |
| 288 | <DD> | |
| 289 | <I>Instance method.</I> | |
| 290 | Write some bytes to the scalar. | |
| 291 | ||
| 292 | <P><DT><B><A NAME="item:sysread">sysread BUF, LEN, [OFFSET]</A></B></DT> | |
| 293 | <DD> | |
| 294 | <I>Instance method.</I> | |
| 295 | Read some bytes from the scalar. | |
| 296 | Returns the number of bytes actually read, 0 on end-of-file, undef on error. | |
| 297 | ||
| 298 | <P><DT><B><A NAME="item:syswrite">syswrite BUF, NBYTES, [OFFSET]</A></B></DT> | |
| 299 | <DD> | |
| 300 | <I>Instance method.</I> | |
| 301 | Write some bytes to the scalar. | |
| 302 | ||
| 303 | </DL> | |
| 304 | ||
| 305 | ||
| 306 | ||
| 307 | <P><HR> | |
| 308 | <A NAME="Seeking_telling_and_other_attributes"><H3><A HREF="#__TOP__"><IMG SRC="icons/h2bullet.gif" ALT="Top" BORDER="0"></A> Seeking/telling and other attributes</H3></A> | |
| 309 | ||
| 310 | ||
| 311 | ||
| 312 | <DL> | |
| 313 | <P><DT><B><A NAME="item:autoflush">autoflush</A></B></DT> | |
| 314 | <DD> | |
| 315 | <I>Instance method.</I> | |
| 316 | No-op, provided for OO compatibility. | |
| 317 | ||
| 318 | <P><DT><B><A NAME="item:binmode">binmode</A></B></DT> | |
| 319 | <DD> | |
| 320 | <I>Instance method.</I> | |
| 321 | No-op, provided for OO compatibility. | |
| 322 | ||
| 323 | <P><DT><B><A NAME="item:clearerr">clearerr</A></B></DT> | |
| 324 | <DD> | |
| 325 | <I>Instance method.</I> Clear the error and EOF flags. A no-op. | |
| 326 | ||
| 327 | <P><DT><B><A NAME="item:eof">eof</A></B></DT> | |
| 328 | <DD> | |
| 329 | <I>Instance method.</I> Are we at end of file? | |
| 330 | ||
| 331 | <P><DT><B><A NAME="item:seek">seek OFFSET, WHENCE</A></B></DT> | |
| 332 | <DD> | |
| 333 | <I>Instance method.</I> Seek to a given position in the stream. | |
| 334 | ||
| 335 | <P><DT><B><A NAME="item:sysseek">sysseek OFFSET, WHENCE</A></B></DT> | |
| 336 | <DD> | |
| 337 | <I>Instance method.</I> Identical to <CODE>seek OFFSET, WHENCE</CODE>, <I>q.v.</I> | |
| 338 | ||
| 339 | <P><DT><B><A NAME="item:tell">tell</A></B></DT> | |
| 340 | <DD> | |
| 341 | <I>Instance method.</I> | |
| 342 | Return the current position in the stream, as a numeric offset. | |
| 343 | ||
| 344 | <P><DT><B><A NAME="item:use_RS">use_RS [YESNO]</A></B></DT> | |
| 345 | <DD> | |
| 346 | <I>Instance method.</I> | |
| 347 | Obey the curent setting of $/, like IO::Handle does? | |
| 348 | Default is false in 1.x, true in 2.x and later. | |
| 349 | ||
| 350 | <P><DT><B><A NAME="item:setpos">setpos POS</A></B></DT> | |
| 351 | <DD> | |
| 352 | <I>Instance method.</I> | |
| 353 | Set the current position, using the opaque value returned by <CODE>getpos()</CODE>. | |
| 354 | ||
| 355 | <P><DT><B><A NAME="item:getpos">getpos</A></B></DT> | |
| 356 | <DD> | |
| 357 | <I>Instance method.</I> | |
| 358 | Return the current position in the string, as an opaque object. | |
| 359 | ||
| 360 | <P><DT><B><A NAME="item:sref">sref</A></B></DT> | |
| 361 | <DD> | |
| 362 | <I>Instance method.</I> | |
| 363 | Return a reference to the underlying scalar. | |
| 364 | ||
| 365 | </DL> | |
| 366 | ||
| 367 | ||
| 368 | ||
| 369 | <P><HR> | |
| 370 | <A NAME="WARNINGS"><H2><A HREF="#__TOP__"><IMG SRC="icons/h1bullet.gif" ALT="Top" BORDER="0"></A> WARNINGS</H2></A> | |
| 371 | ||
| 372 | ||
| 373 | <P>Perl's TIEHANDLE spec was incomplete prior to 5.005_57; | |
| 374 | it was missing support for <CODE>seek()</CODE>, <CODE>tell()</CODE>, and <CODE>eof()</CODE>. | |
| 375 | Attempting to use these functions with an IO::Scalar will not work | |
| 376 | prior to 5.005_57. IO::Scalar will not have the relevant methods | |
| 377 | invoked; and even worse, this kind of bug can lie dormant for a while. | |
| 378 | If you turn warnings on (via <CODE>$^W</CODE> or <CODE>perl -w</CODE>), | |
| 379 | and you see something like this... | |
| 380 | ||
| 381 | <FONT SIZE=3 FACE="courier"><PRE> | |
| 382 | attempt to seek on unopened filehandle | |
| 383 | </PRE></FONT> | |
| 384 | ||
| 385 | <P>...then you are probably trying to use one of these functions | |
| 386 | on an IO::Scalar with an old Perl. The remedy is to simply | |
| 387 | use the OO version; e.g.: | |
| 388 | ||
| 389 | <FONT SIZE=3 FACE="courier"><PRE> | |
| 390 | $SH->seek(0,0); ### GOOD: will work on any 5.005 | |
| 391 | seek($SH,0,0); ### WARNING: will only work on 5.005_57 and beyond | |
| 392 | </PRE></FONT> | |
| 393 | ||
| 394 | ||
| 395 | <P><HR> | |
| 396 | <A NAME="VERSION"><H2><A HREF="#__TOP__"><IMG SRC="icons/h1bullet.gif" ALT="Top" BORDER="0"></A> VERSION</H2></A> | |
| 397 | ||
| 398 | ||
| 399 | <P>$Id: Scalar.pm.html,v 1.2 2005/06/09 14:20:25 nj7w Exp $ | |
| 400 | ||
| 401 | ||
| 402 | ||
| 403 | <P><HR> | |
| 404 | <A NAME="AUTHORS"><H2><A HREF="#__TOP__"><IMG SRC="icons/h1bullet.gif" ALT="Top" BORDER="0"></A> AUTHORS</H2></A> | |
| 405 | ||
| 406 | ||
| 407 | ||
| 408 | <P><HR> | |
| 409 | <A NAME="Principal_author"><H3><A HREF="#__TOP__"><IMG SRC="icons/h2bullet.gif" ALT="Top" BORDER="0"></A> Principal author</H3></A> | |
| 410 | ||
| 411 | ||
| 412 | <P>Eryq (<I><FILE><A HREF="mailto:eryq@zeegee.com">eryq@zeegee.com</A></FILE></I>). | |
| 413 | President, ZeeGee Software Inc (<I><FILE><A HREF="http://www.zeegee.com">http://www.zeegee.com</A></FILE></I>). | |
| 414 | ||
| 415 | ||
| 416 | ||
| 417 | <P><HR> | |
| 418 | <A NAME="Other_contributors"><H3><A HREF="#__TOP__"><IMG SRC="icons/h2bullet.gif" ALT="Top" BORDER="0"></A> Other contributors</H3></A> | |
| 419 | ||
| 420 | ||
| 421 | <P>The full set of contributors always includes the folks mentioned | |
| 422 | in <A HREF="IO/Stringy.pm.html#CHANGE_LOG">CHANGE LOG</A>. But just the same, special | |
| 423 | thanks to the following individuals for their invaluable contributions | |
| 424 | (if I've forgotten or misspelled your name, please email me!): | |
| 425 | ||
| 426 | ||
| 427 | <P><I>Andy Glew,</I> | |
| 428 | for contributing <CODE>getc()</CODE>. | |
| 429 | ||
| 430 | ||
| 431 | <P><I>Brandon Browning,</I> | |
| 432 | for suggesting <CODE>opened()</CODE>. | |
| 433 | ||
| 434 | ||
| 435 | <P><I>David Richter,</I> | |
| 436 | for finding and fixing the bug in <CODE>PRINTF()</CODE>. | |
| 437 | ||
| 438 | ||
| 439 | <P><I>Eric L. Brine,</I> | |
| 440 | for his offset-using read() and write() implementations. | |
| 441 | ||
| 442 | ||
| 443 | <P><I>Richard Jones,</I> | |
| 444 | for his patches to massively improve the performance of <CODE>getline()</CODE> | |
| 445 | and add <CODE>sysread</CODE> and <CODE>syswrite</CODE>. | |
| 446 | ||
| 447 | ||
| 448 | <P><I>B. K. Oxley (binkley),</I> | |
| 449 | for stringification and inheritance improvements, | |
| 450 | and sundry good ideas. | |
| 451 | ||
| 452 | ||
| 453 | <P><I>Doug Wilson,</I> | |
| 454 | for the IO::Handle inheritance and automatic tie-ing. | |
| 455 | ||
| 456 | ||
| 457 | ||
| 458 | <P><HR> | |
| 459 | <A NAME="SEE_ALSO"><H2><A HREF="#__TOP__"><IMG SRC="icons/h1bullet.gif" ALT="Top" BORDER="0"></A> SEE ALSO</H2></A> | |
| 460 | ||
| 461 | ||
| 462 | <P><A HREF="IO/String.pm.html">IO::String</A>, which is quite similar but which was designed | |
| 463 | more-recently and with an IO::Handle-like interface in mind, | |
| 464 | so you could mix OO- and native-filehandle usage without using tied(). | |
| 465 | ||
| 466 | ||
| 467 | <P><I>Note:</I> as of version 2.x, these classes all work like | |
| 468 | their IO::Handle counterparts, so we have comparable | |
| 469 | functionality to IO::String. | |
| 470 | ||
| 471 | <P><HR> | |
| 472 | <ADDRESS><FONT SIZE=-1> | |
| 473 | Generated Wed Aug 8 03:39:45 2001 by cvu_pod2html | |
| 474 | </FONT></ADDRESS> | |
| 475 | </FONT></BODY> | |
| 476 | </HTML> |
| 0 | package IO::ScalarArray; | |
| 1 | ||
| 2 | ||
| 3 | =head1 NAME | |
| 4 | ||
| 5 | IO::ScalarArray - IO:: interface for reading/writing an array of scalars | |
| 6 | ||
| 7 | ||
| 8 | =head1 SYNOPSIS | |
| 9 | ||
| 10 | Perform I/O on strings, using the basic OO interface... | |
| 11 | ||
| 12 | use IO::ScalarArray; | |
| 13 | @data = ("My mes", "sage:\n"); | |
| 14 | ||
| 15 | ### Open a handle on an array, and append to it: | |
| 16 | $AH = new IO::ScalarArray \@data; | |
| 17 | $AH->print("Hello"); | |
| 18 | $AH->print(", world!\nBye now!\n"); | |
| 19 | print "The array is now: ", @data, "\n"; | |
| 20 | ||
| 21 | ### Open a handle on an array, read it line-by-line, then close it: | |
| 22 | $AH = new IO::ScalarArray \@data; | |
| 23 | while (defined($_ = $AH->getline)) { | |
| 24 | print "Got line: $_"; | |
| 25 | } | |
| 26 | $AH->close; | |
| 27 | ||
| 28 | ### Open a handle on an array, and slurp in all the lines: | |
| 29 | $AH = new IO::ScalarArray \@data; | |
| 30 | print "All lines:\n", $AH->getlines; | |
| 31 | ||
| 32 | ### Get the current position (either of two ways): | |
| 33 | $pos = $AH->getpos; | |
| 34 | $offset = $AH->tell; | |
| 35 | ||
| 36 | ### Set the current position (either of two ways): | |
| 37 | $AH->setpos($pos); | |
| 38 | $AH->seek($offset, 0); | |
| 39 | ||
| 40 | ### Open an anonymous temporary array: | |
| 41 | $AH = new IO::ScalarArray; | |
| 42 | $AH->print("Hi there!"); | |
| 43 | print "I printed: ", @{$AH->aref}, "\n"; ### get at value | |
| 44 | ||
| 45 | ||
| 46 | Don't like OO for your I/O? No problem. | |
| 47 | Thanks to the magic of an invisible tie(), the following now | |
| 48 | works out of the box, just as it does with IO::Handle: | |
| 49 | ||
| 50 | use IO::ScalarArray; | |
| 51 | @data = ("My mes", "sage:\n"); | |
| 52 | ||
| 53 | ### Open a handle on an array, and append to it: | |
| 54 | $AH = new IO::ScalarArray \@data; | |
| 55 | print $AH "Hello"; | |
| 56 | print $AH ", world!\nBye now!\n"; | |
| 57 | print "The array is now: ", @data, "\n"; | |
| 58 | ||
| 59 | ### Open a handle on a string, read it line-by-line, then close it: | |
| 60 | $AH = new IO::ScalarArray \@data; | |
| 61 | while (<$AH>) { | |
| 62 | print "Got line: $_"; | |
| 63 | } | |
| 64 | close $AH; | |
| 65 | ||
| 66 | ### Open a handle on a string, and slurp in all the lines: | |
| 67 | $AH = new IO::ScalarArray \@data; | |
| 68 | print "All lines:\n", <$AH>; | |
| 69 | ||
| 70 | ### Get the current position (WARNING: requires 5.6): | |
| 71 | $offset = tell $AH; | |
| 72 | ||
| 73 | ### Set the current position (WARNING: requires 5.6): | |
| 74 | seek $AH, $offset, 0; | |
| 75 | ||
| 76 | ### Open an anonymous temporary scalar: | |
| 77 | $AH = new IO::ScalarArray; | |
| 78 | print $AH "Hi there!"; | |
| 79 | print "I printed: ", @{$AH->aref}, "\n"; ### get at value | |
| 80 | ||
| 81 | ||
| 82 | And for you folks with 1.x code out there: the old tie() style still works, | |
| 83 | though this is I<unnecessary and deprecated>: | |
| 84 | ||
| 85 | use IO::ScalarArray; | |
| 86 | ||
| 87 | ### Writing to a scalar... | |
| 88 | my @a; | |
| 89 | tie *OUT, 'IO::ScalarArray', \@a; | |
| 90 | print OUT "line 1\nline 2\n", "line 3\n"; | |
| 91 | print "Array is now: ", @a, "\n" | |
| 92 | ||
| 93 | ### Reading and writing an anonymous scalar... | |
| 94 | tie *OUT, 'IO::ScalarArray'; | |
| 95 | print OUT "line 1\nline 2\n", "line 3\n"; | |
| 96 | tied(OUT)->seek(0,0); | |
| 97 | while (<OUT>) { | |
| 98 | print "Got line: ", $_; | |
| 99 | } | |
| 100 | ||
| 101 | ||
| 102 | ||
| 103 | =head1 DESCRIPTION | |
| 104 | ||
| 105 | This class is part of the IO::Stringy distribution; | |
| 106 | see L<IO::Stringy> for change log and general information. | |
| 107 | ||
| 108 | The IO::ScalarArray class implements objects which behave just like | |
| 109 | IO::Handle (or FileHandle) objects, except that you may use them | |
| 110 | to write to (or read from) arrays of scalars. Logically, an | |
| 111 | array of scalars defines an in-core "file" whose contents are | |
| 112 | the concatenation of the scalars in the array. The handles created by | |
| 113 | this class are automatically tiehandle'd (though please see L<"WARNINGS"> | |
| 114 | for information relevant to your Perl version). | |
| 115 | ||
| 116 | For writing large amounts of data with individual print() statements, | |
| 117 | this class is likely to be more efficient than IO::Scalar. | |
| 118 | ||
| 119 | Basically, this: | |
| 120 | ||
| 121 | my @a; | |
| 122 | $AH = new IO::ScalarArray \@a; | |
| 123 | $AH->print("Hel", "lo, "); ### OO style | |
| 124 | $AH->print("world!\n"); ### ditto | |
| 125 | ||
| 126 | Or this: | |
| 127 | ||
| 128 | my @a; | |
| 129 | $AH = new IO::ScalarArray \@a; | |
| 130 | print $AH "Hel", "lo, "; ### non-OO style | |
| 131 | print $AH "world!\n"; ### ditto | |
| 132 | ||
| 133 | Causes @a to be set to the following array of 3 strings: | |
| 134 | ||
| 135 | ( "Hel" , | |
| 136 | "lo, " , | |
| 137 | "world!\n" ) | |
| 138 | ||
| 139 | See L<IO::Scalar> and compare with this class. | |
| 140 | ||
| 141 | ||
| 142 | =head1 PUBLIC INTERFACE | |
| 143 | ||
| 144 | =cut | |
| 145 | ||
| 146 | use Carp; | |
| 147 | use strict; | |
| 148 | use vars qw($VERSION @ISA); | |
| 149 | use IO::Handle; | |
| 150 | ||
| 151 | # The package version, both in 1.23 style *and* usable by MakeMaker: | |
| 152 | $VERSION = substr q$Revision: 1.2 $, 10; | |
| 153 | ||
| 154 | # Inheritance: | |
| 155 | @ISA = qw(IO::Handle); | |
| 156 | require IO::WrapTie and push @ISA, 'IO::WrapTie::Slave' if ($] >= 5.004); | |
| 157 | ||
| 158 | ||
| 159 | #============================== | |
| 160 | ||
| 161 | =head2 Construction | |
| 162 | ||
| 163 | =over 4 | |
| 164 | ||
| 165 | =cut | |
| 166 | ||
| 167 | #------------------------------ | |
| 168 | ||
| 169 | =item new [ARGS...] | |
| 170 | ||
| 171 | I<Class method.> | |
| 172 | Return a new, unattached array handle. | |
| 173 | If any arguments are given, they're sent to open(). | |
| 174 | ||
| 175 | =cut | |
| 176 | ||
| 177 | sub new { | |
| 178 | my $proto = shift; | |
| 179 | my $class = ref($proto) || $proto; | |
| 180 | my $self = bless \do { local *FH }, $class; | |
| 181 | tie *$self, $class, $self; | |
| 182 | $self->open(@_); ### open on anonymous by default | |
| 183 | $self; | |
| 184 | } | |
| 185 | sub DESTROY { | |
| 186 | shift->close; | |
| 187 | } | |
| 188 | ||
| 189 | ||
| 190 | #------------------------------ | |
| 191 | ||
| 192 | =item open [ARRAYREF] | |
| 193 | ||
| 194 | I<Instance method.> | |
| 195 | Open the array handle on a new array, pointed to by ARRAYREF. | |
| 196 | If no ARRAYREF is given, a "private" array is created to hold | |
| 197 | the file data. | |
| 198 | ||
| 199 | Returns the self object on success, undefined on error. | |
| 200 | ||
| 201 | =cut | |
| 202 | ||
| 203 | sub open { | |
| 204 | my ($self, $aref) = @_; | |
| 205 | ||
| 206 | ### Sanity: | |
| 207 | defined($aref) or do {my @a; $aref = \@a}; | |
| 208 | (ref($aref) eq "ARRAY") or croak "open needs a ref to a array"; | |
| 209 | ||
| 210 | ### Setup: | |
| 211 | $self->setpos([0,0]); | |
| 212 | *$self->{AR} = $aref; | |
| 213 | $self; | |
| 214 | } | |
| 215 | ||
| 216 | #------------------------------ | |
| 217 | ||
| 218 | =item opened | |
| 219 | ||
| 220 | I<Instance method.> | |
| 221 | Is the array handle opened on something? | |
| 222 | ||
| 223 | =cut | |
| 224 | ||
| 225 | sub opened { | |
| 226 | *{shift()}->{AR}; | |
| 227 | } | |
| 228 | ||
| 229 | #------------------------------ | |
| 230 | ||
| 231 | =item close | |
| 232 | ||
| 233 | I<Instance method.> | |
| 234 | Disassociate the array handle from its underlying array. | |
| 235 | Done automatically on destroy. | |
| 236 | ||
| 237 | =cut | |
| 238 | ||
| 239 | sub close { | |
| 240 | my $self = shift; | |
| 241 | %{*$self} = (); | |
| 242 | 1; | |
| 243 | } | |
| 244 | ||
| 245 | =back | |
| 246 | ||
| 247 | =cut | |
| 248 | ||
| 249 | ||
| 250 | ||
| 251 | #============================== | |
| 252 | ||
| 253 | =head2 Input and output | |
| 254 | ||
| 255 | =over 4 | |
| 256 | ||
| 257 | =cut | |
| 258 | ||
| 259 | #------------------------------ | |
| 260 | ||
| 261 | =item flush | |
| 262 | ||
| 263 | I<Instance method.> | |
| 264 | No-op, provided for OO compatibility. | |
| 265 | ||
| 266 | =cut | |
| 267 | ||
| 268 | sub flush {} | |
| 269 | ||
| 270 | #------------------------------ | |
| 271 | ||
| 272 | =item getc | |
| 273 | ||
| 274 | I<Instance method.> | |
| 275 | Return the next character, or undef if none remain. | |
| 276 | This does a read(1), which is somewhat costly. | |
| 277 | ||
| 278 | =cut | |
| 279 | ||
| 280 | sub getc { | |
| 281 | my $buf = ''; | |
| 282 | ($_[0]->read($buf, 1) ? $buf : undef); | |
| 283 | } | |
| 284 | ||
| 285 | #------------------------------ | |
| 286 | ||
| 287 | =item getline | |
| 288 | ||
| 289 | I<Instance method.> | |
| 290 | Return the next line, or undef on end of data. | |
| 291 | Can safely be called in an array context. | |
| 292 | Currently, lines are delimited by "\n". | |
| 293 | ||
| 294 | =cut | |
| 295 | ||
| 296 | sub getline { | |
| 297 | my $self = shift; | |
| 298 | my ($str, $line) = (undef, ''); | |
| 299 | ||
| 300 | ||
| 301 | ### Minimal impact implementation! | |
| 302 | ### We do the fast fast thing (no regexps) if using the | |
| 303 | ### classic input record separator. | |
| 304 | ||
| 305 | ### Case 1: $/ is undef: slurp all... | |
| 306 | if (!defined($/)) { | |
| 307 | ||
| 308 | ### Get the rest of the current string, followed by remaining strings: | |
| 309 | my $ar = *$self->{AR}; | |
| 310 | my @slurp = ( | |
| 311 | substr($ar->[*$self->{Str}], *$self->{Pos}), | |
| 312 | @$ar[(1 + *$self->{Str}) .. $#$ar ] | |
| 313 | ); | |
| 314 | ||
| 315 | ### Seek to end: | |
| 316 | $self->_setpos_to_eof; | |
| 317 | return join('', @slurp); | |
| 318 | } | |
| 319 | ||
| 320 | ### Case 2: $/ is "\n": | |
| 321 | elsif ($/ eq "\012") { | |
| 322 | ||
| 323 | ### Until we hit EOF (or exitted because of a found line): | |
| 324 | until ($self->eof) { | |
| 325 | ### If at end of current string, go fwd to next one (won't be EOF): | |
| 326 | if ($self->_eos) {++*$self->{Str}, *$self->{Pos}=0}; | |
| 327 | ||
| 328 | ### Get ref to current string in array, and set internal pos mark: | |
| 329 | $str = \(*$self->{AR}[*$self->{Str}]); ### get current string | |
| 330 | pos($$str) = *$self->{Pos}; ### start matching from here | |
| 331 | ||
| 332 | ### Get from here to either \n or end of string, and add to line: | |
| 333 | $$str =~ m/\G(.*?)((\n)|\Z)/g; ### match to 1st \n or EOS | |
| 334 | $line .= $1.$2; ### add it | |
| 335 | *$self->{Pos} += length($1.$2); ### move fwd by len matched | |
| 336 | return $line if $3; ### done, got line with "\n" | |
| 337 | } | |
| 338 | return ($line eq '') ? undef : $line; ### return undef if EOF | |
| 339 | } | |
| 340 | ||
| 341 | ### Case 3: $/ is ref to int. Bail out. | |
| 342 | elsif (ref($/)) { | |
| 343 | croak '$/ given as a ref to int; currently unsupported'; | |
| 344 | } | |
| 345 | ||
| 346 | ### Case 4: $/ is either "" (paragraphs) or something weird... | |
| 347 | ### Bail for now. | |
| 348 | else { | |
| 349 | croak '$/ as given is currently unsupported'; | |
| 350 | } | |
| 351 | } | |
| 352 | ||
| 353 | #------------------------------ | |
| 354 | ||
| 355 | =item getlines | |
| 356 | ||
| 357 | I<Instance method.> | |
| 358 | Get all remaining lines. | |
| 359 | It will croak() if accidentally called in a scalar context. | |
| 360 | ||
| 361 | =cut | |
| 362 | ||
| 363 | sub getlines { | |
| 364 | my $self = shift; | |
| 365 | wantarray or croak("can't call getlines in scalar context!"); | |
| 366 | my ($line, @lines); | |
| 367 | push @lines, $line while (defined($line = $self->getline)); | |
| 368 | @lines; | |
| 369 | } | |
| 370 | ||
| 371 | #------------------------------ | |
| 372 | ||
| 373 | =item print ARGS... | |
| 374 | ||
| 375 | I<Instance method.> | |
| 376 | Print ARGS to the underlying array. | |
| 377 | ||
| 378 | Currently, this always causes a "seek to the end of the array" | |
| 379 | and generates a new array entry. This may change in the future. | |
| 380 | ||
| 381 | =cut | |
| 382 | ||
| 383 | sub print { | |
| 384 | my $self = shift; | |
| 385 | push @{*$self->{AR}}, join('', @_); ### add the data | |
| 386 | $self->_setpos_to_eof; | |
| 387 | 1; | |
| 388 | } | |
| 389 | ||
| 390 | #------------------------------ | |
| 391 | ||
| 392 | =item read BUF, NBYTES, [OFFSET]; | |
| 393 | ||
| 394 | I<Instance method.> | |
| 395 | Read some bytes from the array. | |
| 396 | Returns the number of bytes actually read, 0 on end-of-file, undef on error. | |
| 397 | ||
| 398 | =cut | |
| 399 | ||
| 400 | sub read { | |
| 401 | my $self = $_[0]; | |
| 402 | ### we must use $_[1] as a ref | |
| 403 | my $n = $_[2]; | |
| 404 | my $off = $_[3] || 0; | |
| 405 | ||
| 406 | ### print "getline\n"; | |
| 407 | my $justread; | |
| 408 | my $len; | |
| 409 | ($off ? substr($_[1], $off) : $_[1]) = ''; | |
| 410 | ||
| 411 | ### Stop when we have zero bytes to go, or when we hit EOF: | |
| 412 | my @got; | |
| 413 | until (!$n or $self->eof) { | |
| 414 | ### If at end of current string, go forward to next one (won't be EOF): | |
| 415 | if ($self->_eos) { | |
| 416 | ++*$self->{Str}; | |
| 417 | *$self->{Pos} = 0; | |
| 418 | } | |
| 419 | ||
| 420 | ### Get longest possible desired substring of current string: | |
| 421 | $justread = substr(*$self->{AR}[*$self->{Str}], *$self->{Pos}, $n); | |
| 422 | $len = length($justread); | |
| 423 | push @got, $justread; | |
| 424 | $n -= $len; | |
| 425 | *$self->{Pos} += $len; | |
| 426 | } | |
| 427 | $_[1] .= join('', @got); | |
| 428 | return length($_[1])-$off; | |
| 429 | } | |
| 430 | ||
| 431 | #------------------------------ | |
| 432 | ||
| 433 | =item write BUF, NBYTES, [OFFSET]; | |
| 434 | ||
| 435 | I<Instance method.> | |
| 436 | Write some bytes into the array. | |
| 437 | ||
| 438 | =cut | |
| 439 | ||
| 440 | sub write { | |
| 441 | my $self = $_[0]; | |
| 442 | my $n = $_[2]; | |
| 443 | my $off = $_[3] || 0; | |
| 444 | ||
| 445 | my $data = substr($_[1], $n, $off); | |
| 446 | $n = length($data); | |
| 447 | $self->print($data); | |
| 448 | return $n; | |
| 449 | } | |
| 450 | ||
| 451 | ||
| 452 | =back | |
| 453 | ||
| 454 | =cut | |
| 455 | ||
| 456 | ||
| 457 | ||
| 458 | #============================== | |
| 459 | ||
| 460 | =head2 Seeking/telling and other attributes | |
| 461 | ||
| 462 | =over 4 | |
| 463 | ||
| 464 | =cut | |
| 465 | ||
| 466 | #------------------------------ | |
| 467 | ||
| 468 | =item autoflush | |
| 469 | ||
| 470 | I<Instance method.> | |
| 471 | No-op, provided for OO compatibility. | |
| 472 | ||
| 473 | =cut | |
| 474 | ||
| 475 | sub autoflush {} | |
| 476 | ||
| 477 | #------------------------------ | |
| 478 | ||
| 479 | =item binmode | |
| 480 | ||
| 481 | I<Instance method.> | |
| 482 | No-op, provided for OO compatibility. | |
| 483 | ||
| 484 | =cut | |
| 485 | ||
| 486 | sub binmode {} | |
| 487 | ||
| 488 | #------------------------------ | |
| 489 | ||
| 490 | =item clearerr | |
| 491 | ||
| 492 | I<Instance method.> Clear the error and EOF flags. A no-op. | |
| 493 | ||
| 494 | =cut | |
| 495 | ||
| 496 | sub clearerr { 1 } | |
| 497 | ||
| 498 | #------------------------------ | |
| 499 | ||
| 500 | =item eof | |
| 501 | ||
| 502 | I<Instance method.> Are we at end of file? | |
| 503 | ||
| 504 | =cut | |
| 505 | ||
| 506 | sub eof { | |
| 507 | ### print "checking EOF [*$self->{Str}, *$self->{Pos}]\n"; | |
| 508 | ### print "SR = ", $#{*$self->{AR}}, "\n"; | |
| 509 | ||
| 510 | return 0 if (*{$_[0]}->{Str} < $#{*{$_[0]}->{AR}}); ### before EOA | |
| 511 | return 1 if (*{$_[0]}->{Str} > $#{*{$_[0]}->{AR}}); ### after EOA | |
| 512 | ### ### at EOA, past EOS: | |
| 513 | ((*{$_[0]}->{Str} == $#{*{$_[0]}->{AR}}) && ($_[0]->_eos)); | |
| 514 | } | |
| 515 | ||
| 516 | #------------------------------ | |
| 517 | # | |
| 518 | # _eos | |
| 519 | # | |
| 520 | # I<Instance method, private.> Are we at end of the CURRENT string? | |
| 521 | # | |
| 522 | sub _eos { | |
| 523 | (*{$_[0]}->{Pos} >= length(*{$_[0]}->{AR}[*{$_[0]}->{Str}])); ### past last char | |
| 524 | } | |
| 525 | ||
| 526 | #------------------------------ | |
| 527 | ||
| 528 | =item seek POS,WHENCE | |
| 529 | ||
| 530 | I<Instance method.> | |
| 531 | Seek to a given position in the stream. | |
| 532 | Only a WHENCE of 0 (SEEK_SET) is supported. | |
| 533 | ||
| 534 | =cut | |
| 535 | ||
| 536 | sub seek { | |
| 537 | my ($self, $pos, $whence) = @_; | |
| 538 | ||
| 539 | ### Seek: | |
| 540 | if ($whence == 0) { $self->_seek_set($pos); } | |
| 541 | elsif ($whence == 1) { $self->_seek_cur($pos); } | |
| 542 | elsif ($whence == 2) { $self->_seek_end($pos); } | |
| 543 | else { croak "bad seek whence ($whence)" } | |
| 544 | } | |
| 545 | ||
| 546 | #------------------------------ | |
| 547 | # | |
| 548 | # _seek_set POS | |
| 549 | # | |
| 550 | # Instance method, private. | |
| 551 | # Seek to $pos relative to start: | |
| 552 | # | |
| 553 | sub _seek_set { | |
| 554 | my ($self, $pos) = @_; | |
| 555 | ||
| 556 | ### Advance through array until done: | |
| 557 | my $istr = 0; | |
| 558 | while (($pos >= 0) && ($istr < scalar(@{*$self->{AR}}))) { | |
| 559 | if (length(*$self->{AR}[$istr]) > $pos) { ### it's in this string! | |
| 560 | return $self->setpos([$istr, $pos]); | |
| 561 | } | |
| 562 | else { ### it's in next string | |
| 563 | $pos -= length(*$self->{AR}[$istr++]); ### move forward one string | |
| 564 | } | |
| 565 | } | |
| 566 | ### If we reached this point, pos is at or past end; zoom to EOF: | |
| 567 | return $self->_setpos_to_eof; | |
| 568 | } | |
| 569 | ||
| 570 | #------------------------------ | |
| 571 | # | |
| 572 | # _seek_cur POS | |
| 573 | # | |
| 574 | # Instance method, private. | |
| 575 | # Seek to $pos relative to current position. | |
| 576 | # | |
| 577 | sub _seek_cur { | |
| 578 | my ($self, $pos) = @_; | |
| 579 | $self->_seek_set($self->tell + $pos); | |
| 580 | } | |
| 581 | ||
| 582 | #------------------------------ | |
| 583 | # | |
| 584 | # _seek_end POS | |
| 585 | # | |
| 586 | # Instance method, private. | |
| 587 | # Seek to $pos relative to end. | |
| 588 | # We actually seek relative to beginning, which is simple. | |
| 589 | # | |
| 590 | sub _seek_end { | |
| 591 | my ($self, $pos) = @_; | |
| 592 | $self->_seek_set($self->_tell_eof + $pos); | |
| 593 | } | |
| 594 | ||
| 595 | #------------------------------ | |
| 596 | ||
| 597 | =item tell | |
| 598 | ||
| 599 | I<Instance method.> | |
| 600 | Return the current position in the stream, as a numeric offset. | |
| 601 | ||
| 602 | =cut | |
| 603 | ||
| 604 | sub tell { | |
| 605 | my $self = shift; | |
| 606 | my $off = 0; | |
| 607 | my ($s, $str_s); | |
| 608 | for ($s = 0; $s < *$self->{Str}; $s++) { ### count all "whole" scalars | |
| 609 | defined($str_s = *$self->{AR}[$s]) or $str_s = ''; | |
| 610 | ###print STDERR "COUNTING STRING $s (". length($str_s) . ")\n"; | |
| 611 | $off += length($str_s); | |
| 612 | } | |
| 613 | ###print STDERR "COUNTING POS ($self->{Pos})\n"; | |
| 614 | return ($off += *$self->{Pos}); ### plus the final, partial one | |
| 615 | } | |
| 616 | ||
| 617 | #------------------------------ | |
| 618 | # | |
| 619 | # _tell_eof | |
| 620 | # | |
| 621 | # Instance method, private. | |
| 622 | # Get position of EOF, as a numeric offset. | |
| 623 | # This is identical to the size of the stream - 1. | |
| 624 | # | |
| 625 | sub _tell_eof { | |
| 626 | my $self = shift; | |
| 627 | my $len = 0; | |
| 628 | foreach (@{*$self->{AR}}) { $len += length($_) } | |
| 629 | $len; | |
| 630 | } | |
| 631 | ||
| 632 | #------------------------------ | |
| 633 | ||
| 634 | =item setpos POS | |
| 635 | ||
| 636 | I<Instance method.> | |
| 637 | Seek to a given position in the array, using the opaque getpos() value. | |
| 638 | Don't expect this to be a number. | |
| 639 | ||
| 640 | =cut | |
| 641 | ||
| 642 | sub setpos { | |
| 643 | my ($self, $pos) = @_; | |
| 644 | (ref($pos) eq 'ARRAY') or | |
| 645 | die "setpos: only use a value returned by getpos!\n"; | |
| 646 | (*$self->{Str}, *$self->{Pos}) = @$pos; | |
| 647 | } | |
| 648 | ||
| 649 | #------------------------------ | |
| 650 | # | |
| 651 | # _setpos_to_eof | |
| 652 | # | |
| 653 | # Fast-forward to EOF. | |
| 654 | # | |
| 655 | sub _setpos_to_eof { | |
| 656 | my $self = shift; | |
| 657 | $self->setpos([scalar(@{*$self->{AR}}), 0]); | |
| 658 | } | |
| 659 | ||
| 660 | #------------------------------ | |
| 661 | ||
| 662 | =item getpos | |
| 663 | ||
| 664 | I<Instance method.> | |
| 665 | Return the current position in the array, as an opaque value. | |
| 666 | Don't expect this to be a number. | |
| 667 | ||
| 668 | =cut | |
| 669 | ||
| 670 | sub getpos { | |
| 671 | [*{$_[0]}->{Str}, *{$_[0]}->{Pos}]; | |
| 672 | } | |
| 673 | ||
| 674 | #------------------------------ | |
| 675 | ||
| 676 | =item aref | |
| 677 | ||
| 678 | I<Instance method.> | |
| 679 | Return a reference to the underlying array. | |
| 680 | ||
| 681 | =cut | |
| 682 | ||
| 683 | sub aref { | |
| 684 | *{shift()}->{AR}; | |
| 685 | } | |
| 686 | ||
| 687 | =back | |
| 688 | ||
| 689 | =cut | |
| 690 | ||
| 691 | #------------------------------ | |
| 692 | # Tied handle methods... | |
| 693 | #------------------------------ | |
| 694 | ||
| 695 | ### Conventional tiehandle interface: | |
| 696 | sub TIEHANDLE { (defined($_[1]) && UNIVERSAL::isa($_[1],"IO::ScalarArray")) | |
| 697 | ? $_[1] | |
| 698 | : shift->new(@_) } | |
| 699 | sub GETC { shift->getc(@_) } | |
| 700 | sub PRINT { shift->print(@_) } | |
| 701 | sub PRINTF { shift->print(sprintf(shift, @_)) } | |
| 702 | sub READ { shift->read(@_) } | |
| 703 | sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) } | |
| 704 | sub WRITE { shift->write(@_); } | |
| 705 | sub CLOSE { shift->close(@_); } | |
| 706 | sub SEEK { shift->seek(@_); } | |
| 707 | sub TELL { shift->tell(@_); } | |
| 708 | sub EOF { shift->eof(@_); } | |
| 709 | ||
| 710 | #------------------------------------------------------------ | |
| 711 | ||
| 712 | 1; | |
| 713 | __END__ | |
| 714 | ||
| 715 | # SOME PRIVATE NOTES: | |
| 716 | # | |
| 717 | # * The "current position" is the position before the next | |
| 718 | # character to be read/written. | |
| 719 | # | |
| 720 | # * Str gives the string index of the current position, 0-based | |
| 721 | # | |
| 722 | # * Pos gives the offset within AR[Str], 0-based. | |
| 723 | # | |
| 724 | # * Inital pos is [0,0]. After print("Hello"), it is [1,0]. | |
| 725 | ||
| 726 | ||
| 727 | ||
| 728 | =head1 WARNINGS | |
| 729 | ||
| 730 | Perl's TIEHANDLE spec was incomplete prior to 5.005_57; | |
| 731 | it was missing support for C<seek()>, C<tell()>, and C<eof()>. | |
| 732 | Attempting to use these functions with an IO::ScalarArray will not work | |
| 733 | prior to 5.005_57. IO::ScalarArray will not have the relevant methods | |
| 734 | invoked; and even worse, this kind of bug can lie dormant for a while. | |
| 735 | If you turn warnings on (via C<$^W> or C<perl -w>), | |
| 736 | and you see something like this... | |
| 737 | ||
| 738 | attempt to seek on unopened filehandle | |
| 739 | ||
| 740 | ...then you are probably trying to use one of these functions | |
| 741 | on an IO::ScalarArray with an old Perl. The remedy is to simply | |
| 742 | use the OO version; e.g.: | |
| 743 | ||
| 744 | $AH->seek(0,0); ### GOOD: will work on any 5.005 | |
| 745 | seek($AH,0,0); ### WARNING: will only work on 5.005_57 and beyond | |
| 746 | ||
| 747 | ||
| 748 | ||
| 749 | =head1 VERSION | |
| 750 | ||
| 751 | $Id: ScalarArray.pm,v 1.2 2005/06/09 14:20:25 nj7w Exp $ | |
| 752 | ||
| 753 | ||
| 754 | =head1 AUTHOR | |
| 755 | ||
| 756 | =head2 Principal author | |
| 757 | ||
| 758 | Eryq (F<eryq@zeegee.com>). | |
| 759 | President, ZeeGee Software Inc (F<http://www.zeegee.com>). | |
| 760 | ||
| 761 | ||
| 762 | =head2 Other contributors | |
| 763 | ||
| 764 | Thanks to the following individuals for their invaluable contributions | |
| 765 | (if I've forgotten or misspelled your name, please email me!): | |
| 766 | ||
| 767 | I<Andy Glew,> | |
| 768 | for suggesting C<getc()>. | |
| 769 | ||
| 770 | I<Brandon Browning,> | |
| 771 | for suggesting C<opened()>. | |
| 772 | ||
| 773 | I<Eric L. Brine,> | |
| 774 | for his offset-using read() and write() implementations. | |
| 775 | ||
| 776 | I<Doug Wilson,> | |
| 777 | for the IO::Handle inheritance and automatic tie-ing. | |
| 778 | ||
| 779 | =cut | |
| 780 | ||
| 781 | #------------------------------ | |
| 782 | 1; | |
| 783 |
| 0 | package IO::Stringy; | |
| 1 | ||
| 2 | use vars qw($VERSION); | |
| 3 | $VERSION = substr q$Revision: 1.2 $, 10; | |
| 4 | ||
| 5 | 1; | |
| 6 | __END__ | |
| 7 | ||
| 8 | ||
| 9 | =head1 NAME | |
| 10 | ||
| 11 | IO-stringy - I/O on in-core objects like strings and arrays | |
| 12 | ||
| 13 | ||
| 14 | =head1 SYNOPSIS | |
| 15 | ||
| 16 | IO:: | |
| 17 | ::AtomicFile adpO Write a file which is updated atomically ERYQ | |
| 18 | ::Lines bdpO I/O handle to read/write to array of lines ERYQ | |
| 19 | ::Scalar RdpO I/O handle to read/write to a string ERYQ | |
| 20 | ::ScalarArray RdpO I/O handle to read/write to array of scalars ERYQ | |
| 21 | ::Wrap RdpO Wrap old-style FHs in standard OO interface ERYQ | |
| 22 | ::WrapTie adpO Tie your handles & retain full OO interface ERYQ | |
| 23 | ||
| 24 | ||
| 25 | =head1 DESCRIPTION | |
| 26 | ||
| 27 | This toolkit primarily provides modules for performing both traditional | |
| 28 | and object-oriented i/o) on things I<other> than normal filehandles; | |
| 29 | in particular, L<IO::Scalar|IO::Scalar>, L<IO::ScalarArray|IO::ScalarArray>, | |
| 30 | and L<IO::Lines|IO::Lines>. | |
| 31 | ||
| 32 | In the more-traditional IO::Handle front, we | |
| 33 | have L<IO::AtomicFile|IO::AtomicFile> | |
| 34 | which may be used to painlessly create files which are updated | |
| 35 | atomically. | |
| 36 | ||
| 37 | And in the "this-may-prove-useful" corner, we have L<IO::Wrap|IO::Wrap>, | |
| 38 | whose exported wraphandle() function will clothe anything that's not | |
| 39 | a blessed object in an IO::Handle-like wrapper... so you can just | |
| 40 | use OO syntax and stop worrying about whether your function's caller | |
| 41 | handed you a string, a globref, or a FileHandle. | |
| 42 | ||
| 43 | ||
| 44 | =head1 WARNINGS | |
| 45 | ||
| 46 | Perl's TIEHANDLE spec was incomplete prior to 5.005_57; | |
| 47 | it was missing support for C<seek()>, C<tell()>, and C<eof()>. | |
| 48 | Attempting to use these functions with an IO::Scalar, IO::ScalarArray, | |
| 49 | IO::Lines, etc. B<will not work> prior to 5.005_57. | |
| 50 | None of the relevant methods will be invoked by Perl; | |
| 51 | and even worse, this kind of bug can lie dormant for a while. | |
| 52 | If you turn warnings on (via C<$^W> or C<perl -w>), and you see | |
| 53 | something like this... | |
| 54 | ||
| 55 | seek() on unopened file | |
| 56 | ||
| 57 | ...then you are probably trying to use one of these functions | |
| 58 | on one of our IO:: classes with an old Perl. The remedy is to simply | |
| 59 | use the OO version; e.g.: | |
| 60 | ||
| 61 | $SH->seek(0,0); ### GOOD: will work on any 5.005 | |
| 62 | seek($SH,0,0); ### WARNING: will only work on 5.005_57 and beyond | |
| 63 | ||
| 64 | ||
| 65 | ||
| 66 | =head1 INSTALLATION | |
| 67 | ||
| 68 | ||
| 69 | =head2 Requirements | |
| 70 | ||
| 71 | As of version 2.x, this toolkit requires Perl 5.005 for | |
| 72 | the IO::Handle subclasses, and 5.005_57 or better is | |
| 73 | B<strongly> recommended. See L<"WARNINGS"> for details. | |
| 74 | ||
| 75 | ||
| 76 | =head2 Directions | |
| 77 | ||
| 78 | Most of you already know the drill... | |
| 79 | ||
| 80 | perl Makefile.PL | |
| 81 | make | |
| 82 | make test | |
| 83 | make install | |
| 84 | ||
| 85 | For everyone else out there... | |
| 86 | if you've never installed Perl code before, or you're trying to use | |
| 87 | this in an environment where your sysadmin or ISP won't let you do | |
| 88 | interesting things, B<relax:> since this module contains no binary | |
| 89 | extensions, you can cheat. That means copying the directory tree | |
| 90 | under my "./lib" directory into someplace where your script can "see" | |
| 91 | it. For example, under Linux: | |
| 92 | ||
| 93 | cp -r IO-stringy-1.234/lib/* /path/to/my/perl/ | |
| 94 | ||
| 95 | Now, in your Perl code, do this: | |
| 96 | ||
| 97 | use lib "/path/to/my/perl"; | |
| 98 | use IO::Scalar; ### or whatever | |
| 99 | ||
| 100 | Ok, now you've been told. At this point, anyone who whines about | |
| 101 | not being given enough information gets an unflattering haiku | |
| 102 | written about them in the next change log. I'll do it. | |
| 103 | Don't think I won't. | |
| 104 | ||
| 105 | ||
| 106 | ||
| 107 | =head1 VERSION | |
| 108 | ||
| 109 | $Id: Stringy.pm,v 1.2 2005/06/09 14:20:25 nj7w Exp $ | |
| 110 | ||
| 111 | ||
| 112 | ||
| 113 | =head1 TO DO | |
| 114 | ||
| 115 | =over 4 | |
| 116 | ||
| 117 | =item (2000/08/02) Finalize $/ support | |
| 118 | ||
| 119 | Graham Barr submitted this patch half a I<year> ago; | |
| 120 | Like a moron, I lost his message under a ton of others, | |
| 121 | and only now have the experimental implementation done. | |
| 122 | ||
| 123 | Will the sudden sensitivity to $/ hose anyone out there? | |
| 124 | I'm worried, so you have to enable it explicitly in 1.x. | |
| 125 | It will be on by default in 2.x, though only IO::Scalar | |
| 126 | has been implemented. | |
| 127 | ||
| 128 | ||
| 129 | =item (2000/09/28) Separate read/write cursors? | |
| 130 | ||
| 131 | Binkley sent me a very interesting variant of IO::Scalar which | |
| 132 | maintains two separate cursors on the data, one for reading | |
| 133 | and one for writing. Quoth he: | |
| 134 | ||
| 135 | Isn't it the case that real operating system file descriptors | |
| 136 | maintain an independent read and write file position (and | |
| 137 | seek(2) resets them both)? | |
| 138 | ||
| 139 | (My answer: perhaps, but stdio's fseek/ftell manpages seem to | |
| 140 | imply a single file position indicator, and I'm trying to be IO::-ish.) | |
| 141 | Binkley also pointed out some issues with his implementation: | |
| 142 | ||
| 143 | For example, what does eof or tell return? The read position or | |
| 144 | the write position? (I assumed read position was more important). | |
| 145 | ||
| 146 | Your opinions on this are most welcome. | |
| 147 | (Me, I'm just squeamish that this will break some code | |
| 148 | which depends on the existing behavior, and that attempts to | |
| 149 | maintain backwards-compatibility will slow down the code.) | |
| 150 | ||
| 151 | ||
| 152 | =item (2001/08/08) Remove IO::WrapTie from new IO:: classes | |
| 153 | ||
| 154 | It's not needed. Backwards compatibility could be maintained | |
| 155 | by having new_tie() be identical to new(). Heck, I'll bet | |
| 156 | that IO::WrapTie should be reimplemented so the returned | |
| 157 | object is just like an IO::Scalar in its use of globrefs. | |
| 158 | ||
| 159 | ||
| 160 | =back | |
| 161 | ||
| 162 | ||
| 163 | ||
| 164 | =head1 CHANGE LOG | |
| 165 | ||
| 166 | =over 4 | |
| 167 | ||
| 168 | ||
| 169 | =item Version 2.109 (2003/12/21) | |
| 170 | ||
| 171 | IO::Scalar::getline now works with ref to int. | |
| 172 | I<Thanks to Dominique Quatravaux for this patch.> | |
| 173 | ||
| 174 | ||
| 175 | =item Version 2.108 (2001/08/20) | |
| 176 | ||
| 177 | The terms-of-use have been placed in the distribution file "COPYING". | |
| 178 | Also, small documentation tweaks were made. | |
| 179 | ||
| 180 | ||
| 181 | =item Version 2.105 (2001/08/09) | |
| 182 | ||
| 183 | Added support for various seek() whences to IO::ScalarArray. | |
| 184 | ||
| 185 | Added support for consulting $/ in IO::Scalar and IO::ScalarArray. | |
| 186 | The old C<use_RS()> is not even an option. | |
| 187 | Unsupported record separators will cause a croak(). | |
| 188 | ||
| 189 | Added a lot of regression tests to supoprt the above. | |
| 190 | ||
| 191 | Better on-line docs (hyperlinks to individual functions). | |
| 192 | ||
| 193 | ||
| 194 | =item Version 2.103 (2001/08/08) | |
| 195 | ||
| 196 | After sober consideration I have reimplemented IO::Scalar::print() | |
| 197 | so that it once again always seeks to the end of the string. | |
| 198 | Benchmarks show the new implementation to be just as fast as | |
| 199 | Juergen's contributed patch; until someone can convince me otherwise, | |
| 200 | the current, safer implementation stays. | |
| 201 | ||
| 202 | I thought more about giving IO::Scalar two separate handles, | |
| 203 | one for reading and one for writing, as suggested by Binkley. | |
| 204 | His points about what tell() and eof() return are, I think, | |
| 205 | show-stoppers for this feature. Even the manpages for stdio's fseek() | |
| 206 | seem to imply a I<single> file position indicator, not two. | |
| 207 | So I think I will take this off the TO DO list. | |
| 208 | B<Remedy:> you can always have two handles open on the same | |
| 209 | scalar, one which you only write to, and one which you only read from. | |
| 210 | That should give the same effect. | |
| 211 | ||
| 212 | ||
| 213 | =item Version 2.101 (2001/08/07) | |
| 214 | ||
| 215 | B<Alpha release.> | |
| 216 | This is the initial release of the "IO::Scalar and friends are | |
| 217 | now subclasses of IO::Handle". I'm flinging it against the wall. | |
| 218 | Please tell me if the banana sticks. When it does, the banana | |
| 219 | will be called 2.2x. | |
| 220 | ||
| 221 | First off, I<many many thanks to Doug Wilson>, who | |
| 222 | has provided an I<invaluable> service by patching IO::Scalar | |
| 223 | and friends so that they (1) inherit from IO::Handle, (2) automatically | |
| 224 | tie themselves so that the C<new()> objects can be used in native i/o | |
| 225 | constructs, and (3) doing it so that the whole damn thing passes | |
| 226 | its regression tests. As Doug knows, my globref Kung-Fu was not | |
| 227 | up to the task; he graciously provided the patches. This has earned | |
| 228 | him a seat at the L<Co-Authors|"AUTHOR"> table, and the | |
| 229 | right to have me address him as I<sensei>. | |
| 230 | ||
| 231 | Performance of IO::Scalar::print() has been improved by as much as 2x | |
| 232 | for lots of little prints, with the cost of forcing those | |
| 233 | who print-then-seek-then-print to explicitly seek to end-of-string | |
| 234 | before printing again. | |
| 235 | I<Thanks to Juergen Zeller for this patch.> | |
| 236 | ||
| 237 | Added the COPYING file, which had been missing from prior versions. | |
| 238 | I<Thanks to Albert Chin-A-Young for pointing this out.> | |
| 239 | ||
| 240 | IO::Scalar consults $/ by default (1.x ignored it by default). | |
| 241 | Yes, I still need to support IO::ScalarArray. | |
| 242 | ||
| 243 | ||
| 244 | =item Version 1.221 (2001/08/07) | |
| 245 | ||
| 246 | I threatened in L<"INSTALLATION"> to write an unflattering haiku | |
| 247 | about anyone who whined that I gave them insufficient information... | |
| 248 | but it turns out that I left out a crucial direction. D'OH! | |
| 249 | I<Thanks to David Beroff for the "patch" and the haiku...> | |
| 250 | ||
| 251 | Enough info there? | |
| 252 | Here's unflattering haiku: | |
| 253 | Forgot the line, "make"! ;-) | |
| 254 | ||
| 255 | ||
| 256 | ||
| 257 | =item Version 1.220 (2001/04/03) | |
| 258 | ||
| 259 | Added untested SEEK, TELL, and EOF methods to IO::Scalar | |
| 260 | and IO::ScalarArray to support corresponding functions for | |
| 261 | tied filehandles: untested, because I'm still running 5.00556 | |
| 262 | and Perl is complaining about "tell() on unopened file". | |
| 263 | I<Thanks to Graham Barr for the suggestion.> | |
| 264 | ||
| 265 | Removed not-fully-blank lines from modules; these were causing | |
| 266 | lots of POD-related warnings. | |
| 267 | I<Thanks to Nicolas Joly for the suggestion.> | |
| 268 | ||
| 269 | ||
| 270 | =item Version 1.219 (2001/02/23) | |
| 271 | ||
| 272 | IO::Scalar objects can now be made sensitive to $/ . | |
| 273 | Pains were taken to keep the fast code fast while adding this feature. | |
| 274 | I<Cheers to Graham Barr for submitting his patch; | |
| 275 | jeers to me for losing his email for 6 months.> | |
| 276 | ||
| 277 | ||
| 278 | =item Version 1.218 (2001/02/23) | |
| 279 | ||
| 280 | IO::Scalar has a new sysseek() method. | |
| 281 | I<Thanks again to Richard Jones.> | |
| 282 | ||
| 283 | New "TO DO" section, because people who submit patches/ideas should | |
| 284 | at least know that they're in the system... and that I won't lose | |
| 285 | their stuff. Please read it. | |
| 286 | ||
| 287 | New entries in L<"AUTHOR">. | |
| 288 | Please read those too. | |
| 289 | ||
| 290 | ||
| 291 | ||
| 292 | =item Version 1.216 (2000/09/28) | |
| 293 | ||
| 294 | B<IO::Scalar and IO::ScalarArray now inherit from IO::Handle.> | |
| 295 | I thought I'd remembered a problem with this ages ago, related to | |
| 296 | the fact that these IO:: modules don't have "real" filehandles, | |
| 297 | but the problem apparently isn't surfacing now. | |
| 298 | If you suddenly encounter Perl warnings during global destruction | |
| 299 | (especially if you're using tied filehandles), then please let me know! | |
| 300 | I<Thanks to B. K. Oxley (binkley) for this.> | |
| 301 | ||
| 302 | B<Nasty bug fixed in IO::Scalar::write().> | |
| 303 | Apparently, the offset and the number-of-bytes arguments were, | |
| 304 | for all practical purposes, I<reversed.> You were okay if | |
| 305 | you did all your writing with print(), but boy was I<this> a stupid bug! | |
| 306 | I<Thanks to Richard Jones for finding this one. | |
| 307 | For you, Rich, a double-length haiku:> | |
| 308 | ||
| 309 | Newspaper headline | |
| 310 | typeset by dyslexic man | |
| 311 | loses urgency | |
| 312 | ||
| 313 | BABY EATS FISH is | |
| 314 | simply not equivalent | |
| 315 | to FISH EATS BABY | |
| 316 | ||
| 317 | B<New sysread and syswrite methods for IO::Scalar.> | |
| 318 | I<Thanks again to Richard Jones for this.> | |
| 319 | ||
| 320 | ||
| 321 | =item Version 1.215 (2000/09/05) | |
| 322 | ||
| 323 | Added 'bool' overload to '""' overload, so object always evaluates | |
| 324 | to true. (Whew. Glad I caught this before it went to CPAN.) | |
| 325 | ||
| 326 | ||
| 327 | =item Version 1.214 (2000/09/03) | |
| 328 | ||
| 329 | Evaluating an IO::Scalar in a string context now yields | |
| 330 | the underlying string. | |
| 331 | I<Thanks to B. K. Oxley (binkley) for this.> | |
| 332 | ||
| 333 | ||
| 334 | =item Version 1.213 (2000/08/16) | |
| 335 | ||
| 336 | Minor documentation fixes. | |
| 337 | ||
| 338 | ||
| 339 | =item Version 1.212 (2000/06/02) | |
| 340 | ||
| 341 | Fixed IO::InnerFile incompatibility with Perl5.004. | |
| 342 | I<Thanks to many folks for reporting this.> | |
| 343 | ||
| 344 | ||
| 345 | =item Version 1.210 (2000/04/17) | |
| 346 | ||
| 347 | Added flush() and other no-op methods. | |
| 348 | I<Thanks to Doru Petrescu for suggesting this.> | |
| 349 | ||
| 350 | ||
| 351 | =item Version 1.209 (2000/03/17) | |
| 352 | ||
| 353 | Small bug fixes. | |
| 354 | ||
| 355 | ||
| 356 | =item Version 1.208 (2000/03/14) | |
| 357 | ||
| 358 | Incorporated a number of contributed patches and extensions, | |
| 359 | mostly related to speed hacks, support for "offset", and | |
| 360 | WRITE/CLOSE methods. | |
| 361 | I<Thanks to Richard Jones, Doru Petrescu, and many others.> | |
| 362 | ||
| 363 | ||
| 364 | ||
| 365 | =item Version 1.206 (1999/04/18) | |
| 366 | ||
| 367 | Added creation of ./testout when Makefile.PL is run. | |
| 368 | ||
| 369 | ||
| 370 | =item Version 1.205 (1999/01/15) | |
| 371 | ||
| 372 | Verified for Perl5.005. | |
| 373 | ||
| 374 | ||
| 375 | =item Version 1.202 (1998/04/18) | |
| 376 | ||
| 377 | New IO::WrapTie and IO::AtomicFile added. | |
| 378 | ||
| 379 | ||
| 380 | =item Version 1.110 | |
| 381 | ||
| 382 | Added IO::WrapTie. | |
| 383 | ||
| 384 | ||
| 385 | =item Version 1.107 | |
| 386 | ||
| 387 | Added IO::Lines, and made some bug fixes to IO::ScalarArray. | |
| 388 | Also, added getc(). | |
| 389 | ||
| 390 | ||
| 391 | =item Version 1.105 | |
| 392 | ||
| 393 | No real changes; just upgraded IO::Wrap to have a $VERSION string. | |
| 394 | ||
| 395 | =back | |
| 396 | ||
| 397 | ||
| 398 | ||
| 399 | ||
| 400 | =head1 AUTHOR | |
| 401 | ||
| 402 | =over 4 | |
| 403 | ||
| 404 | =item Primary Maintainer | |
| 405 | ||
| 406 | Eryq (F<eryq@zeegee.com>). | |
| 407 | President, ZeeGee Software Inc (F<http://www.zeegee.com>). | |
| 408 | ||
| 409 | =item Co-Authors | |
| 410 | ||
| 411 | For all their bug reports and patch submissions, the following | |
| 412 | are officially recognized: | |
| 413 | ||
| 414 | Richard Jones | |
| 415 | B. K. Oxley (binkley) | |
| 416 | Doru Petrescu | |
| 417 | Doug Wilson (for picking up the ball I dropped, and doing tie() right) | |
| 418 | ||
| 419 | ||
| 420 | =back | |
| 421 | ||
| 422 | Go to F<http://www.zeegee.com> for the latest downloads | |
| 423 | and on-line documentation for this module. | |
| 424 | ||
| 425 | Enjoy. Yell if it breaks. | |
| 426 | ||
| 427 | ||
| 428 | =cut | |
| 429 |
| 0 | package IO::Wrap; | |
| 1 | ||
| 2 | # SEE DOCUMENTATION AT BOTTOM OF FILE | |
| 3 | ||
| 4 | require 5.002; | |
| 5 | ||
| 6 | use strict; | |
| 7 | use vars qw(@ISA @EXPORT $VERSION); | |
| 8 | @ISA = qw(Exporter); | |
| 9 | @EXPORT = qw(wraphandle); | |
| 10 | ||
| 11 | use FileHandle; | |
| 12 | use Carp; | |
| 13 | ||
| 14 | # The package version, both in 1.23 style *and* usable by MakeMaker: | |
| 15 | $VERSION = substr q$Revision: 1.2 $, 10; | |
| 16 | ||
| 17 | ||
| 18 | #------------------------------ | |
| 19 | # wraphandle RAW | |
| 20 | #------------------------------ | |
| 21 | sub wraphandle { | |
| 22 | my $raw = shift; | |
| 23 | new IO::Wrap $raw; | |
| 24 | } | |
| 25 | ||
| 26 | #------------------------------ | |
| 27 | # new STREAM | |
| 28 | #------------------------------ | |
| 29 | sub new { | |
| 30 | my ($class, $stream) = @_; | |
| 31 | no strict 'refs'; | |
| 32 | ||
| 33 | ### Convert raw scalar to globref: | |
| 34 | ref($stream) or $stream = \*$stream; | |
| 35 | ||
| 36 | ### Wrap globref and incomplete objects: | |
| 37 | if ((ref($stream) eq 'GLOB') or ### globref | |
| 38 | (ref($stream) eq 'FileHandle') && !defined(&FileHandle::read)) { | |
| 39 | return bless \$stream, $class; | |
| 40 | } | |
| 41 | $stream; ### already okay! | |
| 42 | } | |
| 43 | ||
| 44 | #------------------------------ | |
| 45 | # I/O methods... | |
| 46 | #------------------------------ | |
| 47 | sub close { | |
| 48 | my $self = shift; | |
| 49 | return close($$self); | |
| 50 | } | |
| 51 | sub getline { | |
| 52 | my $self = shift; | |
| 53 | my $fh = $$self; | |
| 54 | return scalar(<$fh>); | |
| 55 | } | |
| 56 | sub getlines { | |
| 57 | my $self = shift; | |
| 58 | wantarray or croak("Can't call getlines in scalar context!"); | |
| 59 | my $fh = $$self; | |
| 60 | <$fh>; | |
| 61 | } | |
| 62 | sub print { | |
| 63 | my $self = shift; | |
| 64 | print { $$self } @_; | |
| 65 | } | |
| 66 | sub read { | |
| 67 | my $self = shift; | |
| 68 | return read($$self, $_[0], $_[1]); | |
| 69 | } | |
| 70 | sub seek { | |
| 71 | my $self = shift; | |
| 72 | return seek($$self, $_[0], $_[1]); | |
| 73 | } | |
| 74 | sub tell { | |
| 75 | my $self = shift; | |
| 76 | return tell($$self); | |
| 77 | } | |
| 78 | ||
| 79 | #------------------------------ | |
| 80 | 1; | |
| 81 | __END__ | |
| 82 | ||
| 83 | ||
| 84 | =head1 NAME | |
| 85 | ||
| 86 | IO::Wrap - wrap raw filehandles in IO::Handle interface | |
| 87 | ||
| 88 | ||
| 89 | =head1 SYNOPSIS | |
| 90 | ||
| 91 | use IO::Wrap; | |
| 92 | ||
| 93 | ### Do stuff with any kind of filehandle (including a bare globref), or | |
| 94 | ### any kind of blessed object that responds to a print() message. | |
| 95 | ### | |
| 96 | sub do_stuff { | |
| 97 | my $fh = shift; | |
| 98 | ||
| 99 | ### At this point, we have no idea what the user gave us... | |
| 100 | ### a globref? a FileHandle? a scalar filehandle name? | |
| 101 | ||
| 102 | $fh = wraphandle($fh); | |
| 103 | ||
| 104 | ### At this point, we know we have an IO::Handle-like object! | |
| 105 | ||
| 106 | $fh->print("Hey there!"); | |
| 107 | ... | |
| 108 | } | |
| 109 | ||
| 110 | ||
| 111 | =head1 DESCRIPTION | |
| 112 | ||
| 113 | Let's say you want to write some code which does I/O, but you don't | |
| 114 | want to force the caller to provide you with a FileHandle or IO::Handle | |
| 115 | object. You want them to be able to say: | |
| 116 | ||
| 117 | do_stuff(\*STDOUT); | |
| 118 | do_stuff('STDERR'); | |
| 119 | do_stuff($some_FileHandle_object); | |
| 120 | do_stuff($some_IO_Handle_object); | |
| 121 | ||
| 122 | And even: | |
| 123 | ||
| 124 | do_stuff($any_object_with_a_print_method); | |
| 125 | ||
| 126 | Sure, one way to do it is to force the caller to use tiehandle(). | |
| 127 | But that puts the burden on them. Another way to do it is to | |
| 128 | use B<IO::Wrap>, which provides you with the following functions: | |
| 129 | ||
| 130 | ||
| 131 | =over 4 | |
| 132 | ||
| 133 | =item wraphandle SCALAR | |
| 134 | ||
| 135 | This function will take a single argument, and "wrap" it based on | |
| 136 | what it seems to be... | |
| 137 | ||
| 138 | =over 4 | |
| 139 | ||
| 140 | =item * | |
| 141 | ||
| 142 | B<A raw scalar filehandle name,> like C<"STDOUT"> or C<"Class::HANDLE">. | |
| 143 | In this case, the filehandle name is wrapped in an IO::Wrap object, | |
| 144 | which is returned. | |
| 145 | ||
| 146 | =item * | |
| 147 | ||
| 148 | B<A raw filehandle glob,> like C<\*STDOUT>. | |
| 149 | In this case, the filehandle glob is wrapped in an IO::Wrap object, | |
| 150 | which is returned. | |
| 151 | ||
| 152 | =item * | |
| 153 | ||
| 154 | B<A blessed FileHandle object.> | |
| 155 | In this case, the FileHandle is wrapped in an IO::Wrap object if and only | |
| 156 | if your FileHandle class does not support the C<read()> method. | |
| 157 | ||
| 158 | =item * | |
| 159 | ||
| 160 | B<Any other kind of blessed object,> which is assumed to be already | |
| 161 | conformant to the IO::Handle interface. | |
| 162 | In this case, you just get back that object. | |
| 163 | ||
| 164 | =back | |
| 165 | ||
| 166 | =back | |
| 167 | ||
| 168 | ||
| 169 | If you get back an IO::Wrap object, it will obey a basic subset of | |
| 170 | the IO:: interface. That is, the following methods (note: I said | |
| 171 | I<methods>, not named operators) should work on the thing you get back: | |
| 172 | ||
| 173 | close | |
| 174 | getline | |
| 175 | getlines | |
| 176 | print ARGS... | |
| 177 | read BUFFER,NBYTES | |
| 178 | seek POS,WHENCE | |
| 179 | tell | |
| 180 | ||
| 181 | ||
| 182 | ||
| 183 | =head1 NOTES | |
| 184 | ||
| 185 | Clearly, when wrapping a raw external filehandle (like \*STDOUT), | |
| 186 | I didn't want to close the file descriptor when the "wrapper" object is | |
| 187 | destroyed... since the user might not appreciate that! Hence, | |
| 188 | there's no DESTROY method in this class. | |
| 189 | ||
| 190 | When wrapping a FileHandle object, however, I believe that Perl will | |
| 191 | invoke the FileHandle::DESTROY when the last reference goes away, | |
| 192 | so in that case, the filehandle is closed if the wrapped FileHandle | |
| 193 | really was the last reference to it. | |
| 194 | ||
| 195 | ||
| 196 | =head1 WARNINGS | |
| 197 | ||
| 198 | This module does not allow you to wrap filehandle names which are given | |
| 199 | as strings that lack the package they were opened in. That is, if a user | |
| 200 | opens FOO in package Foo, they must pass it to you either as C<\*FOO> | |
| 201 | or as C<"Foo::FOO">. However, C<"STDIN"> and friends will work just fine. | |
| 202 | ||
| 203 | ||
| 204 | =head1 VERSION | |
| 205 | ||
| 206 | $Id: Wrap.pm,v 1.2 2005/06/09 14:20:25 nj7w Exp $ | |
| 207 | ||
| 208 | ||
| 209 | =head1 AUTHOR | |
| 210 | ||
| 211 | Eryq (F<eryq@zeegee.com>). | |
| 212 | President, ZeeGee Software Inc (F<http://www.zeegee.com>). | |
| 213 | ||
| 214 | =cut | |
| 215 |
| 0 | # SEE DOCUMENTATION AT BOTTOM OF FILE | |
| 1 | ||
| 2 | ||
| 3 | #------------------------------------------------------------ | |
| 4 | package IO::WrapTie; | |
| 5 | #------------------------------------------------------------ | |
| 6 | require 5.004; ### for tie | |
| 7 | use strict; | |
| 8 | use vars qw(@ISA @EXPORT $VERSION); | |
| 9 | use Exporter; | |
| 10 | ||
| 11 | # Inheritance, exporting, and package version: | |
| 12 | @ISA = qw(Exporter); | |
| 13 | @EXPORT = qw(wraptie); | |
| 14 | $VERSION = substr q$Revision: 1.2 $, 10; | |
| 15 | ||
| 16 | # Function, exported. | |
| 17 | sub wraptie { | |
| 18 | IO::WrapTie::Master->new(@_); | |
| 19 | } | |
| 20 | ||
| 21 | # Class method; BACKWARDS-COMPATIBILITY ONLY! | |
| 22 | sub new { | |
| 23 | shift; | |
| 24 | IO::WrapTie::Master->new(@_); | |
| 25 | } | |
| 26 | ||
| 27 | ||
| 28 | ||
| 29 | #------------------------------------------------------------ | |
| 30 | package IO::WrapTie::Master; | |
| 31 | #------------------------------------------------------------ | |
| 32 | ||
| 33 | use strict; | |
| 34 | use vars qw(@ISA $AUTOLOAD); | |
| 35 | use IO::Handle; | |
| 36 | ||
| 37 | # We inherit from IO::Handle to get methods which invoke i/o operators, | |
| 38 | # like print(), on our tied handle: | |
| 39 | @ISA = qw(IO::Handle); | |
| 40 | ||
| 41 | #------------------------------ | |
| 42 | # new SLAVE, TIEARGS... | |
| 43 | #------------------------------ | |
| 44 | # Create a new subclass of IO::Handle which... | |
| 45 | # | |
| 46 | # (1) Handles i/o OPERATORS because it is tied to an instance of | |
| 47 | # an i/o-like class, like IO::Scalar. | |
| 48 | # | |
| 49 | # (2) Handles i/o METHODS by delegating them to that same tied object!. | |
| 50 | # | |
| 51 | # Arguments are the slave class (e.g., IO::Scalar), followed by all | |
| 52 | # the arguments normally sent into that class's TIEHANDLE method. | |
| 53 | # In other words, much like the arguments to tie(). :-) | |
| 54 | # | |
| 55 | # NOTE: | |
| 56 | # The thing $x we return must be a BLESSED REF, for ($x->print()). | |
| 57 | # The underlying symbol must be a FILEHANDLE, for (print $x "foo"). | |
| 58 | # It has to have a way of getting to the "real" back-end object... | |
| 59 | # | |
| 60 | sub new { | |
| 61 | my $master = shift; | |
| 62 | my $io = IO::Handle->new; ### create a new handle | |
| 63 | my $slave = shift; | |
| 64 | tie *$io, $slave, @_; ### tie: will invoke slave's TIEHANDLE | |
| 65 | bless $io, $master; ### return a master | |
| 66 | } | |
| 67 | ||
| 68 | #------------------------------ | |
| 69 | # AUTOLOAD | |
| 70 | #------------------------------ | |
| 71 | # Delegate method invocations on the master to the underlying slave. | |
| 72 | # | |
| 73 | sub AUTOLOAD { | |
| 74 | my $method = $AUTOLOAD; | |
| 75 | $method =~ s/.*:://; | |
| 76 | my $self = shift; tied(*$self)->$method(\@_); | |
| 77 | } | |
| 78 | ||
| 79 | #------------------------------ | |
| 80 | # PRELOAD | |
| 81 | #------------------------------ | |
| 82 | # Utility. | |
| 83 | # | |
| 84 | # Most methods like print(), getline(), etc. which work on the tied object | |
| 85 | # via Perl's i/o operators (like 'print') are inherited from IO::Handle. | |
| 86 | # | |
| 87 | # Other methods, like seek() and sref(), we must delegate ourselves. | |
| 88 | # AUTOLOAD takes care of these. | |
| 89 | # | |
| 90 | # However, it may be necessary to preload delegators into your | |
| 91 | # own class. PRELOAD will do this. | |
| 92 | # | |
| 93 | sub PRELOAD { | |
| 94 | my $class = shift; | |
| 95 | foreach (@_) { | |
| 96 | eval "sub ${class}::$_ { my \$s = shift; tied(*\$s)->$_(\@_) }"; | |
| 97 | } | |
| 98 | } | |
| 99 | ||
| 100 | # Preload delegators for some standard methods which we can't simply | |
| 101 | # inherit from IO::Handle... for example, some IO::Handle methods | |
| 102 | # assume that there is an underlying file descriptor. | |
| 103 | # | |
| 104 | PRELOAD IO::WrapTie::Master | |
| 105 | qw(open opened close read clearerr eof seek tell setpos getpos); | |
| 106 | ||
| 107 | ||
| 108 | ||
| 109 | #------------------------------------------------------------ | |
| 110 | package IO::WrapTie::Slave; | |
| 111 | #------------------------------------------------------------ | |
| 112 | # Teeny private class providing a new_tie constructor... | |
| 113 | # | |
| 114 | # HOW IT ALL WORKS: | |
| 115 | # | |
| 116 | # Slaves inherit from this class. | |
| 117 | # | |
| 118 | # When you send a new_tie() message to a tie-slave class (like IO::Scalar), | |
| 119 | # it first determines what class should provide its master, via TIE_MASTER. | |
| 120 | # In this case, IO::Scalar->TIE_MASTER would return IO::Scalar::Master. | |
| 121 | # Then, we create a new master (an IO::Scalar::Master) with the same args | |
| 122 | # sent to new_tie. | |
| 123 | # | |
| 124 | # In general, the new() method of the master is inherited directly | |
| 125 | # from IO::WrapTie::Master. | |
| 126 | # | |
| 127 | sub new_tie { | |
| 128 | my $self = shift; | |
| 129 | $self->TIE_MASTER->new($self,@_); ### e.g., IO::Scalar::Master->new(@_) | |
| 130 | } | |
| 131 | ||
| 132 | # Default class method for new_tie(). | |
| 133 | # All your tie-slave class (like IO::Scalar) has to do is override this | |
| 134 | # method with a method that returns the name of an appropriate "master" | |
| 135 | # class for tying that slave. | |
| 136 | # | |
| 137 | sub TIE_MASTER { 'IO::WrapTie::Master' } | |
| 138 | ||
| 139 | #------------------------------ | |
| 140 | 1; | |
| 141 | __END__ | |
| 142 | ||
| 143 | ||
| 144 | package IO::WrapTie; ### for doc generator | |
| 145 | ||
| 146 | ||
| 147 | =head1 NAME | |
| 148 | ||
| 149 | IO::WrapTie - wrap tieable objects in IO::Handle interface | |
| 150 | ||
| 151 | I<This is currently Alpha code, released for comments. | |
| 152 | Please give me your feedback!> | |
| 153 | ||
| 154 | ||
| 155 | =head1 SYNOPSIS | |
| 156 | ||
| 157 | First of all, you'll need tie(), so: | |
| 158 | ||
| 159 | require 5.004; | |
| 160 | ||
| 161 | I<Function interface (experimental).> | |
| 162 | Use this with any existing class... | |
| 163 | ||
| 164 | use IO::WrapTie; | |
| 165 | use FooHandle; ### implements TIEHANDLE interface | |
| 166 | ||
| 167 | ### Suppose we want a "FooHandle->new(&FOO_RDWR, 2)". | |
| 168 | ### We can instead say... | |
| 169 | ||
| 170 | $FH = wraptie('FooHandle', &FOO_RDWR, 2); | |
| 171 | ||
| 172 | ### Now we can use... | |
| 173 | print $FH "Hello, "; ### traditional operator syntax... | |
| 174 | $FH->print("world!\n"); ### ...and OO syntax as well! | |
| 175 | ||
| 176 | I<OO interface (preferred).> | |
| 177 | You can inherit from the IO::WrapTie::Slave mixin to get a | |
| 178 | nifty C<new_tie()> constructor... | |
| 179 | ||
| 180 | #------------------------------ | |
| 181 | package FooHandle; ### a class which can TIEHANDLE | |
| 182 | ||
| 183 | use IO::WrapTie; | |
| 184 | @ISA = qw(IO::WrapTie::Slave); ### inherit new_tie() | |
| 185 | ... | |
| 186 | ||
| 187 | ||
| 188 | #------------------------------ | |
| 189 | package main; | |
| 190 | ||
| 191 | $FH = FooHandle->new_tie(&FOO_RDWR, 2); ### $FH is an IO::WrapTie::Master | |
| 192 | print $FH "Hello, "; ### traditional operator syntax | |
| 193 | $FH->print("world!\n"); ### OO syntax | |
| 194 | ||
| 195 | See IO::Scalar as an example. It also shows you how to create classes | |
| 196 | which work both with and without 5.004. | |
| 197 | ||
| 198 | ||
| 199 | =head1 DESCRIPTION | |
| 200 | ||
| 201 | Suppose you have a class C<FooHandle>, where... | |
| 202 | ||
| 203 | =over 4 | |
| 204 | ||
| 205 | =item * | |
| 206 | ||
| 207 | B<FooHandle does not inherit from IO::Handle;> that is, it performs | |
| 208 | filehandle-like I/O, but to something other than an underlying | |
| 209 | file descriptor. Good examples are IO::Scalar (for printing to a | |
| 210 | string) and IO::Lines (for printing to an array of lines). | |
| 211 | ||
| 212 | =item * | |
| 213 | ||
| 214 | B<FooHandle implements the TIEHANDLE interface> (see L<perltie>); | |
| 215 | that is, it provides methods TIEHANDLE, GETC, PRINT, PRINTF, | |
| 216 | READ, and READLINE. | |
| 217 | ||
| 218 | =item * | |
| 219 | ||
| 220 | B<FooHandle implements the traditional OO interface> of | |
| 221 | FileHandle and IO::Handle; i.e., it contains methods like getline(), | |
| 222 | read(), print(), seek(), tell(), eof(), etc. | |
| 223 | ||
| 224 | =back | |
| 225 | ||
| 226 | ||
| 227 | Normally, users of your class would have two options: | |
| 228 | ||
| 229 | ||
| 230 | =over 4 | |
| 231 | ||
| 232 | =item * | |
| 233 | ||
| 234 | B<Use only OO syntax,> and forsake named I/O operators like 'print'. | |
| 235 | ||
| 236 | =item * | |
| 237 | ||
| 238 | B<Use with tie,> and forsake treating it as a first-class object | |
| 239 | (i.e., class-specific methods can only be invoked through the underlying | |
| 240 | object via tied()... giving the object a "split personality"). | |
| 241 | ||
| 242 | =back | |
| 243 | ||
| 244 | ||
| 245 | But now with IO::WrapTie, you can say: | |
| 246 | ||
| 247 | $WT = wraptie('FooHandle', &FOO_RDWR, 2); | |
| 248 | $WT->print("Hello, world\n"); ### OO syntax | |
| 249 | print $WT "Yes!\n"; ### Named operator syntax too! | |
| 250 | $WT->weird_stuff; ### Other methods! | |
| 251 | ||
| 252 | And if you're authoring a class like FooHandle, just have it inherit | |
| 253 | from C<IO::WrapTie::Slave> and that first line becomes even prettier: | |
| 254 | ||
| 255 | $WT = FooHandle->new_tie(&FOO_RDWR, 2); | |
| 256 | ||
| 257 | B<The bottom line:> now, almost any class can look and work exactly like | |
| 258 | an IO::Handle... and be used both with OO and non-OO filehandle syntax. | |
| 259 | ||
| 260 | ||
| 261 | =head1 HOW IT ALL WORKS | |
| 262 | ||
| 263 | ||
| 264 | =head2 The data structures | |
| 265 | ||
| 266 | Consider this example code, using classes in this distribution: | |
| 267 | ||
| 268 | use IO::Scalar; | |
| 269 | use IO::WrapTie; | |
| 270 | ||
| 271 | $WT = wraptie('IO::Scalar',\$s); | |
| 272 | print $WT "Hello, "; | |
| 273 | $WT->print("world!\n"); | |
| 274 | ||
| 275 | In it, the wraptie() function creates a data structure as follows: | |
| 276 | ||
| 277 | * $WT is a blessed reference to a tied filehandle | |
| 278 | $WT glob; that glob is tied to the "Slave" object. | |
| 279 | | * You would do all your i/o with $WT directly. | |
| 280 | | | |
| 281 | | | |
| 282 | | ,---isa--> IO::WrapTie::Master >--isa--> IO::Handle | |
| 283 | V / | |
| 284 | .-------------. | |
| 285 | | | | |
| 286 | | | * Perl i/o operators work on the tied object, | |
| 287 | | "Master" | invoking the TIEHANDLE methods. | |
| 288 | | | * Method invocations are delegated to the tied | |
| 289 | | | slave. | |
| 290 | `-------------' | |
| 291 | | | |
| 292 | tied(*$WT) | .---isa--> IO::WrapTie::Slave | |
| 293 | V / | |
| 294 | .-------------. | |
| 295 | | | | |
| 296 | | "Slave" | * Instance of FileHandle-like class which doesn't | |
| 297 | | | actually use file descriptors, like IO::Scalar. | |
| 298 | | IO::Scalar | * The slave can be any kind of object. | |
| 299 | | | * Must implement the TIEHANDLE interface. | |
| 300 | `-------------' | |
| 301 | ||
| 302 | ||
| 303 | I<NOTE:> just as an IO::Handle is really just a blessed reference to a | |
| 304 | I<traditional> filehandle glob... so also, an IO::WrapTie::Master | |
| 305 | is really just a blessed reference to a filehandle | |
| 306 | glob I<which has been tied to some "slave" class.> | |
| 307 | ||
| 308 | ||
| 309 | =head2 How wraptie() works | |
| 310 | ||
| 311 | =over 4 | |
| 312 | ||
| 313 | =item 1. | |
| 314 | ||
| 315 | The call to function C<wraptie(SLAVECLASS, TIEARGS...)> is | |
| 316 | passed onto C<IO::WrapTie::Master::new()>. | |
| 317 | Note that class IO::WrapTie::Master is a subclass of IO::Handle. | |
| 318 | ||
| 319 | =item 2. | |
| 320 | ||
| 321 | The C<IO::WrapTie::Master::new> method creates a new IO::Handle object, | |
| 322 | reblessed into class IO::WrapTie::Master. This object is the I<master>, | |
| 323 | which will be returned from the constructor. At the same time... | |
| 324 | ||
| 325 | =item 3. | |
| 326 | ||
| 327 | The C<new> method also creates the I<slave>: this is an instance | |
| 328 | of SLAVECLASS which is created by tying the master's IO::Handle | |
| 329 | to SLAVECLASS via C<tie(HANDLE, SLAVECLASS, TIEARGS...)>. | |
| 330 | This call to C<tie()> creates the slave in the following manner: | |
| 331 | ||
| 332 | =item 4. | |
| 333 | ||
| 334 | Class SLAVECLASS is sent the message C<TIEHANDLE(TIEARGS...)>; it | |
| 335 | will usually delegate this to C<SLAVECLASS::new(TIEARGS...)>, resulting | |
| 336 | in a new instance of SLAVECLASS being created and returned. | |
| 337 | ||
| 338 | =item 5. | |
| 339 | ||
| 340 | Once both master and slave have been created, the master is returned | |
| 341 | to the caller. | |
| 342 | ||
| 343 | =back | |
| 344 | ||
| 345 | ||
| 346 | =head2 How I/O operators work (on the master) | |
| 347 | ||
| 348 | Consider using an i/o operator on the master: | |
| 349 | ||
| 350 | print $WT "Hello, world!\n"; | |
| 351 | ||
| 352 | Since the master ($WT) is really a [blessed] reference to a glob, | |
| 353 | the normal Perl i/o operators like C<print> may be used on it. | |
| 354 | They will just operate on the symbol part of the glob. | |
| 355 | ||
| 356 | Since the glob is tied to the slave, the slave's PRINT method | |
| 357 | (part of the TIEHANDLE interface) will be automatically invoked. | |
| 358 | ||
| 359 | If the slave is an IO::Scalar, that means IO::Scalar::PRINT will be | |
| 360 | invoked, and that method happens to delegate to the C<print()> method | |
| 361 | of the same class. So the I<real> work is ultimately done by | |
| 362 | IO::Scalar::print(). | |
| 363 | ||
| 364 | ||
| 365 | =head2 How methods work (on the master) | |
| 366 | ||
| 367 | Consider using a method on the master: | |
| 368 | ||
| 369 | $WT->print("Hello, world!\n"); | |
| 370 | ||
| 371 | Since the master ($WT) is blessed into the class IO::WrapTie::Master, | |
| 372 | Perl first attempts to find a C<print()> method there. Failing that, | |
| 373 | Perl next attempts to find a C<print()> method in the superclass, | |
| 374 | IO::Handle. It just so happens that there I<is> such a method; | |
| 375 | that method merely invokes the C<print> i/o operator on the self object... | |
| 376 | and for that, see above! | |
| 377 | ||
| 378 | But let's suppose we're dealing with a method which I<isn't> part | |
| 379 | of IO::Handle... for example: | |
| 380 | ||
| 381 | my $sref = $WT->sref; | |
| 382 | ||
| 383 | In this case, the intuitive behavior is to have the master delegate the | |
| 384 | method invocation to the slave (now do you see where the designations | |
| 385 | come from?). This is indeed what happens: IO::WrapTie::Master contains | |
| 386 | an AUTOLOAD method which performs the delegation. | |
| 387 | ||
| 388 | So: when C<sref()> can't be found in IO::Handle, the AUTOLOAD method | |
| 389 | of IO::WrapTie::Master is invoked, and the standard behavior of | |
| 390 | delegating the method to the underlying slave (here, an IO::Scalar) | |
| 391 | is done. | |
| 392 | ||
| 393 | Sometimes, to get this to work properly, you may need to create | |
| 394 | a subclass of IO::WrapTie::Master which is an effective master for | |
| 395 | I<your> class, and do the delegation there. | |
| 396 | ||
| 397 | ||
| 398 | ||
| 399 | ||
| 400 | =head1 NOTES | |
| 401 | ||
| 402 | B<Why not simply use the object's OO interface?> | |
| 403 | Because that means forsaking the use of named operators | |
| 404 | like print(), and you may need to pass the object to a subroutine | |
| 405 | which will attempt to use those operators: | |
| 406 | ||
| 407 | $O = FooHandle->new(&FOO_RDWR, 2); | |
| 408 | $O->print("Hello, world\n"); ### OO syntax is okay, BUT.... | |
| 409 | ||
| 410 | sub nope { print $_[0] "Nope!\n" } | |
| 411 | X nope($O); ### ERROR!!! (not a glob ref) | |
| 412 | ||
| 413 | ||
| 414 | B<Why not simply use tie()?> | |
| 415 | Because (1) you have to use tied() to invoke methods in the | |
| 416 | object's public interface (yuck), and (2) you may need to pass | |
| 417 | the tied symbol to another subroutine which will attempt to treat | |
| 418 | it in an OO-way... and that will break it: | |
| 419 | ||
| 420 | tie *T, 'FooHandle', &FOO_RDWR, 2; | |
| 421 | print T "Hello, world\n"; ### Operator is okay, BUT... | |
| 422 | ||
| 423 | tied(*T)->other_stuff; ### yuck! AND... | |
| 424 | ||
| 425 | sub nope { shift->print("Nope!\n") } | |
| 426 | X nope(\*T); ### ERROR!!! (method "print" on unblessed ref) | |
| 427 | ||
| 428 | ||
| 429 | B<Why a master and slave? | |
| 430 | Why not simply write FooHandle to inherit from IO::Handle?> | |
| 431 | I tried this, with an implementation similar to that of IO::Socket. | |
| 432 | The problem is that I<the whole point is to use this with objects | |
| 433 | that don't have an underlying file/socket descriptor.>. | |
| 434 | Subclassing IO::Handle will work fine for the OO stuff, and fine with | |
| 435 | named operators I<if> you tie()... but if you just attempt to say: | |
| 436 | ||
| 437 | $IO = FooHandle->new(&FOO_RDWR, 2); | |
| 438 | print $IO "Hello!\n"; | |
| 439 | ||
| 440 | you get a warning from Perl like: | |
| 441 | ||
| 442 | Filehandle GEN001 never opened | |
| 443 | ||
| 444 | because it's trying to do system-level i/o on an (unopened) file | |
| 445 | descriptor. To avoid this, you apparently have to tie() the handle... | |
| 446 | which brings us right back to where we started! At least the | |
| 447 | IO::WrapTie mixin lets us say: | |
| 448 | ||
| 449 | $IO = FooHandle->new_tie(&FOO_RDWR, 2); | |
| 450 | print $IO "Hello!\n"; | |
| 451 | ||
| 452 | and so is not I<too> bad. C<:-)> | |
| 453 | ||
| 454 | ||
| 455 | =head1 WARNINGS | |
| 456 | ||
| 457 | Remember: this stuff is for doing FileHandle-like i/o on things | |
| 458 | I<without underlying file descriptors>. If you have an underlying | |
| 459 | file descriptor, you're better off just inheriting from IO::Handle. | |
| 460 | ||
| 461 | B<Be aware that new_tie() always returns an instance of a | |
| 462 | kind of IO::WrapTie::Master...> it does B<not> return an instance | |
| 463 | of the i/o class you're tying to! | |
| 464 | ||
| 465 | Invoking some methods on the master object causes AUTOLOAD to delegate | |
| 466 | them to the slave object... so it I<looks> like you're manipulating a | |
| 467 | "FooHandle" object directly, but you're not. | |
| 468 | ||
| 469 | I have not explored all the ramifications of this use of tie(). | |
| 470 | I<Here there be dragons>. | |
| 471 | ||
| 472 | ||
| 473 | =head1 VERSION | |
| 474 | ||
| 475 | $Id: WrapTie.pm,v 1.2 2005/06/09 14:20:25 nj7w Exp $ | |
| 476 | ||
| 477 | ||
| 478 | =head1 AUTHOR | |
| 479 | ||
| 480 | Eryq (F<eryq@zeegee.com>). | |
| 481 | President, ZeeGee Software Inc (F<http://www.zeegee.com>). | |
| 482 | ||
| 483 | =cut | |
| 484 |
| 0 | # OLE::Storage_Lite | |
| 1 | # by Kawai, Takanori (Hippo2000) 2000.11.4, 8, 14 | |
| 2 | # This Program is Still ALPHA version. | |
| 3 | #////////////////////////////////////////////////////////////////////////////// | |
| 4 | # OLE::Storage_Lite::PPS Object | |
| 5 | #////////////////////////////////////////////////////////////////////////////// | |
| 6 | #============================================================================== | |
| 7 | # OLE::Storage_Lite::PPS | |
| 8 | #============================================================================== | |
| 9 | package OLE::Storage_Lite::PPS; | |
| 10 | require Exporter; | |
| 11 | use strict; | |
| 12 | use Math::BigInt; | |
| 13 | #use OLE::Storage_Lite; | |
| 14 | use vars qw($VERSION @ISA); | |
| 15 | @ISA = qw(Exporter); | |
| 16 | $VERSION = '0.11'; | |
| 17 | ||
| 18 | #------------------------------------------------------------------------------ | |
| 19 | # new (OLE::Storage_Lite::PPS) | |
| 20 | #------------------------------------------------------------------------------ | |
| 21 | sub new ($$$$$$$$$$;$$) { | |
| 22 | #1. Constructor for General Usage | |
| 23 | my($sClass, $iNo, $sNm, $iType, $iPrev, $iNext, $iDir, | |
| 24 | $raTime1st, $raTime2nd, $iStart, $iSize, $sData, $raChild) = @_; | |
| 25 | ||
| 26 | if($iType == OLE::Storage_Lite::PpsType_File()) { #FILE | |
| 27 | return OLE::Storage_Lite::PPS::File->_new | |
| 28 | ($iNo, $sNm, $iType, $iPrev, $iNext, $iDir, $raTime1st, $raTime2nd, | |
| 29 | $iStart, $iSize, $sData, $raChild); | |
| 30 | } | |
| 31 | elsif($iType == OLE::Storage_Lite::PpsType_Dir()) { #DIRECTRY | |
| 32 | return OLE::Storage_Lite::PPS::Dir->_new | |
| 33 | ($iNo, $sNm, $iType, $iPrev, $iNext, $iDir, $raTime1st, $raTime2nd, | |
| 34 | $iStart, $iSize, $sData, $raChild); | |
| 35 | } | |
| 36 | elsif($iType == OLE::Storage_Lite::PpsType_Root()) { #ROOT | |
| 37 | return OLE::Storage_Lite::PPS::Root->_new | |
| 38 | ($iNo, $sNm, $iType, $iPrev, $iNext, $iDir, $raTime1st, $raTime2nd, | |
| 39 | $iStart, $iSize, $sData, $raChild); | |
| 40 | } | |
| 41 | else { | |
| 42 | die "Error PPS:$iType $sNm\n"; | |
| 43 | } | |
| 44 | } | |
| 45 | #------------------------------------------------------------------------------ | |
| 46 | # _new (OLE::Storage_Lite::PPS) | |
| 47 | # for OLE::Storage_Lite | |
| 48 | #------------------------------------------------------------------------------ | |
| 49 | sub _new ($$$$$$$$$$$;$$) { | |
| 50 | my($sClass, $iNo, $sNm, $iType, $iPrev, $iNext, $iDir, | |
| 51 | $raTime1st, $raTime2nd, $iStart, $iSize, $sData, $raChild) = @_; | |
| 52 | #1. Constructor for OLE::Storage_Lite | |
| 53 | my $oThis = { | |
| 54 | No => $iNo, | |
| 55 | Name => $sNm, | |
| 56 | Type => $iType, | |
| 57 | PrevPps => $iPrev, | |
| 58 | NextPps => $iNext, | |
| 59 | DirPps => $iDir, | |
| 60 | Time1st => $raTime1st, | |
| 61 | Time2nd => $raTime2nd, | |
| 62 | StartBlock => $iStart, | |
| 63 | Size => $iSize, | |
| 64 | Data => $sData, | |
| 65 | Child => $raChild, | |
| 66 | }; | |
| 67 | bless $oThis, $sClass; | |
| 68 | return $oThis; | |
| 69 | } | |
| 70 | #------------------------------------------------------------------------------ | |
| 71 | # _DataLen (OLE::Storage_Lite::PPS) | |
| 72 | # Check for update | |
| 73 | #------------------------------------------------------------------------------ | |
| 74 | sub _DataLen($) { | |
| 75 | my($oSelf) =@_; | |
| 76 | return 0 unless(defined($oSelf->{Data})); | |
| 77 | return ($oSelf->{_PPS_FILE})? | |
| 78 | ($oSelf->{_PPS_FILE}->stat())[7] : length($oSelf->{Data}); | |
| 79 | } | |
| 80 | #------------------------------------------------------------------------------ | |
| 81 | # _makeSmallData (OLE::Storage_Lite::PPS) | |
| 82 | #------------------------------------------------------------------------------ | |
| 83 | sub _makeSmallData($$$) { | |
| 84 | my($oThis, $aList, $rhInfo) = @_; | |
| 85 | my ($sRes); | |
| 86 | my $FILE = $rhInfo->{_FILEH_}; | |
| 87 | my $iSmBlk = 0; | |
| 88 | ||
| 89 | foreach my $oPps (@$aList) { | |
| 90 | #1. Make SBD, small data string | |
| 91 | if($oPps->{Type}==OLE::Storage_Lite::PpsType_File()) { | |
| 92 | next if($oPps->{Size}<=0); | |
| 93 | if($oPps->{Size} < $rhInfo->{_SMALL_SIZE}) { | |
| 94 | my $iSmbCnt = int($oPps->{Size} / $rhInfo->{_SMALL_BLOCK_SIZE}) | |
| 95 | + (($oPps->{Size} % $rhInfo->{_SMALL_BLOCK_SIZE})? 1: 0); | |
| 96 | #1.1 Add to SBD | |
| 97 | for (my $i = 0; $i<($iSmbCnt-1); $i++) { | |
| 98 | $FILE->print(pack("V", $i+$iSmBlk+1)); | |
| 99 | } | |
| 100 | $FILE->print(pack("V", -2)); | |
| 101 | ||
| 102 | #1.2 Add to Data String(this will be written for RootEntry) | |
| 103 | #Check for update | |
| 104 | if($oPps->{_PPS_FILE}) { | |
| 105 | my $sBuff; | |
| 106 | $oPps->{_PPS_FILE}->seek(0, 0); #To The Top | |
| 107 | while($oPps->{_PPS_FILE}->read($sBuff, 4096)) { | |
| 108 | $sRes .= $sBuff; | |
| 109 | } | |
| 110 | } | |
| 111 | else { | |
| 112 | $sRes .= $oPps->{Data}; | |
| 113 | } | |
| 114 | $sRes .= ("\x00" x | |
| 115 | ($rhInfo->{_SMALL_BLOCK_SIZE} - ($oPps->{Size}% $rhInfo->{_SMALL_BLOCK_SIZE}))) | |
| 116 | if($oPps->{Size}% $rhInfo->{_SMALL_BLOCK_SIZE}); | |
| 117 | #1.3 Set for PPS | |
| 118 | $oPps->{StartBlock} = $iSmBlk; | |
| 119 | $iSmBlk += $iSmbCnt; | |
| 120 | } | |
| 121 | } | |
| 122 | } | |
| 123 | my $iSbCnt = int($rhInfo->{_BIG_BLOCK_SIZE}/ OLE::Storage_Lite::LongIntSize()); | |
| 124 | $FILE->print(pack("V", -1) x ($iSbCnt - ($iSmBlk % $iSbCnt))) | |
| 125 | if($iSmBlk % $iSbCnt); | |
| 126 | #2. Write SBD with adjusting length for block | |
| 127 | return $sRes; | |
| 128 | } | |
| 129 | #------------------------------------------------------------------------------ | |
| 130 | # _savePpsWk (OLE::Storage_Lite::PPS) | |
| 131 | #------------------------------------------------------------------------------ | |
| 132 | sub _savePpsWk($$) | |
| 133 | { | |
| 134 | my($oThis, $rhInfo) = @_; | |
| 135 | #1. Write PPS | |
| 136 | my $FILE = $rhInfo->{_FILEH_}; | |
| 137 | $FILE->print( | |
| 138 | $oThis->{Name} | |
| 139 | . ("\x00" x (64 - length($oThis->{Name}))) #64 | |
| 140 | , pack("v", length($oThis->{Name}) + 2) #66 | |
| 141 | , pack("c", $oThis->{Type}) #67 | |
| 142 | , pack("c", 0x00) #UK #68 | |
| 143 | , pack("V", $oThis->{PrevPps}) #Prev #72 | |
| 144 | , pack("V", $oThis->{NextPps}) #Next #76 | |
| 145 | , pack("V", $oThis->{DirPps}) #Dir #80 | |
| 146 | , "\x00\x09\x02\x00" #84 | |
| 147 | , "\x00\x00\x00\x00" #88 | |
| 148 | , "\xc0\x00\x00\x00" #92 | |
| 149 | , "\x00\x00\x00\x46" #96 | |
| 150 | , "\x00\x00\x00\x00" #100 | |
| 151 | , OLE::Storage_Lite::LocalDate2OLE($oThis->{Time1st}) #108 | |
| 152 | , OLE::Storage_Lite::LocalDate2OLE($oThis->{Time2nd}) #116 | |
| 153 | , pack("V", defined($oThis->{StartBlock})? | |
| 154 | $oThis->{StartBlock}:0) #116 | |
| 155 | , pack("V", defined($oThis->{Size})? | |
| 156 | $oThis->{Size} : 0) #124 | |
| 157 | , pack("V", 0), #128 | |
| 158 | ); | |
| 159 | } | |
| 160 | ||
| 161 | #////////////////////////////////////////////////////////////////////////////// | |
| 162 | # OLE::Storage_Lite::PPS::Root Object | |
| 163 | #////////////////////////////////////////////////////////////////////////////// | |
| 164 | #============================================================================== | |
| 165 | # OLE::Storage_Lite::PPS::Root | |
| 166 | #============================================================================== | |
| 167 | package OLE::Storage_Lite::PPS::Root; | |
| 168 | require Exporter; | |
| 169 | use strict; | |
| 170 | use IO::Scalar; | |
| 171 | use IO::File; | |
| 172 | use IO::Handle; | |
| 173 | use Fcntl; | |
| 174 | use vars qw($VERSION @ISA); | |
| 175 | @ISA = qw(OLE::Storage_Lite::PPS Exporter); | |
| 176 | $VERSION = '0.11'; | |
| 177 | sub _savePpsSetPnt($$$); | |
| 178 | sub _savePpsSetPnt2($$$); | |
| 179 | #------------------------------------------------------------------------------ | |
| 180 | # new (OLE::Storage_Lite::PPS::Root) | |
| 181 | #------------------------------------------------------------------------------ | |
| 182 | sub new ($;$$$) { | |
| 183 | my($sClass, $raTime1st, $raTime2nd, $raChild) = @_; | |
| 184 | OLE::Storage_Lite::PPS::_new( | |
| 185 | $sClass, | |
| 186 | undef, | |
| 187 | OLE::Storage_Lite::Asc2Ucs('Root Entry'), | |
| 188 | 5, | |
| 189 | undef, | |
| 190 | undef, | |
| 191 | undef, | |
| 192 | $raTime1st, | |
| 193 | $raTime2nd, | |
| 194 | undef, | |
| 195 | undef, | |
| 196 | undef, | |
| 197 | $raChild); | |
| 198 | } | |
| 199 | #------------------------------------------------------------------------------ | |
| 200 | # save (OLE::Storage_Lite::PPS::Root) | |
| 201 | #------------------------------------------------------------------------------ | |
| 202 | sub save($$;$$) { | |
| 203 | my($oThis, $sFile, $bNoAs, $rhInfo) = @_; | |
| 204 | #0.Initial Setting for saving | |
| 205 | $rhInfo = {} unless($rhInfo); | |
| 206 | $rhInfo->{_BIG_BLOCK_SIZE} = 2** | |
| 207 | (($rhInfo->{_BIG_BLOCK_SIZE})? | |
| 208 | _adjust2($rhInfo->{_BIG_BLOCK_SIZE}) : 9); | |
| 209 | $rhInfo->{_SMALL_BLOCK_SIZE}= 2 ** | |
| 210 | (($rhInfo->{_SMALL_BLOCK_SIZE})? | |
| 211 | _adjust2($rhInfo->{_SMALL_BLOCK_SIZE}): 6); | |
| 212 | $rhInfo->{_SMALL_SIZE} = 0x1000; | |
| 213 | $rhInfo->{_PPS_SIZE} = 0x80; | |
| 214 | ||
| 215 | #1.Open File | |
| 216 | #1.1 $sFile is Ref of scalar | |
| 217 | if(ref($sFile) eq 'SCALAR') { | |
| 218 | my $oIo = new IO::Scalar $sFile, O_WRONLY; | |
| 219 | $rhInfo->{_FILEH_} = $oIo; | |
| 220 | } | |
| 221 | #1.2 $sFile is a IO::Handle object | |
| 222 | elsif(UNIVERSAL::isa($sFile, 'IO::Handle')) { | |
| 223 | binmode($sFile); | |
| 224 | $rhInfo->{_FILEH_} = $sFile; | |
| 225 | } | |
| 226 | #1.3 $sFile is a simple filename string | |
| 227 | elsif(!ref($sFile)) { | |
| 228 | if($sFile ne '-') { | |
| 229 | my $oIo = new IO::File; | |
| 230 | $oIo->open(">$sFile") || return undef; | |
| 231 | binmode($oIo); | |
| 232 | $rhInfo->{_FILEH_} = $oIo; | |
| 233 | } | |
| 234 | else { | |
| 235 | my $oIo = new IO::Handle; | |
| 236 | $oIo->fdopen(fileno(STDOUT),"w") || return undef; | |
| 237 | binmode($oIo); | |
| 238 | $rhInfo->{_FILEH_} = $oIo; | |
| 239 | } | |
| 240 | } | |
| 241 | #1.4 Others | |
| 242 | else { | |
| 243 | return undef; | |
| 244 | } | |
| 245 | ||
| 246 | my $iBlk = 0; | |
| 247 | #1. Make an array of PPS (for Save) | |
| 248 | my @aList=(); | |
| 249 | if($bNoAs) { | |
| 250 | _savePpsSetPnt2([$oThis], \@aList, $rhInfo); | |
| 251 | } | |
| 252 | else { | |
| 253 | _savePpsSetPnt([$oThis], \@aList, $rhInfo); | |
| 254 | } | |
| 255 | my ($iSBDcnt, $iBBcnt, $iPPScnt) = $oThis->_calcSize(\@aList, $rhInfo); | |
| 256 | #2.Save Header | |
| 257 | $oThis->_saveHeader($rhInfo, $iSBDcnt, $iBBcnt, $iPPScnt); | |
| 258 | ||
| 259 | #3.Make Small Data string (write SBD) | |
| 260 | my $sSmWk = $oThis->_makeSmallData(\@aList, $rhInfo); | |
| 261 | $oThis->{Data} = $sSmWk; #Small Datas become RootEntry Data | |
| 262 | ||
| 263 | #4. Write BB | |
| 264 | my $iBBlk = $iSBDcnt; | |
| 265 | $oThis->_saveBigData(\$iBBlk, \@aList, $rhInfo); | |
| 266 | #5. Write PPS | |
| 267 | $oThis->_savePps(\@aList, $rhInfo); | |
| 268 | #6. Write BD and BDList and Adding Header informations | |
| 269 | $oThis->_saveBbd($iSBDcnt, $iBBcnt, $iPPScnt, $rhInfo); | |
| 270 | #7.Close File | |
| 271 | $rhInfo->{_FILEH_}->close unless($sFile ne '-'); | |
| 272 | } | |
| 273 | #------------------------------------------------------------------------------ | |
| 274 | # _calcSize (OLE::Storage_Lite::PPS) | |
| 275 | #------------------------------------------------------------------------------ | |
| 276 | sub _calcSize($$) | |
| 277 | { | |
| 278 | my($oThis, $raList, $rhInfo) = @_; | |
| 279 | ||
| 280 | #0. Calculate Basic Setting | |
| 281 | my ($iSBDcnt, $iBBcnt, $iPPScnt) = (0,0,0); | |
| 282 | my $iSmallLen = 0; | |
| 283 | my $iSBcnt = 0; | |
| 284 | ||
| 285 | foreach my $oPps (@$raList) { | |
| 286 | if($oPps->{Type}==OLE::Storage_Lite::PpsType_File()) { | |
| 287 | $oPps->{Size} = $oPps->_DataLen(); #Mod | |
| 288 | if($oPps->{Size} < $rhInfo->{_SMALL_SIZE}) { | |
| 289 | $iSBcnt += int($oPps->{Size} / $rhInfo->{_SMALL_BLOCK_SIZE}) | |
| 290 | + (($oPps->{Size} % $rhInfo->{_SMALL_BLOCK_SIZE})? 1: 0); | |
| 291 | } | |
| 292 | else { | |
| 293 | $iBBcnt += | |
| 294 | (int($oPps->{Size}/ $rhInfo->{_BIG_BLOCK_SIZE}) + | |
| 295 | (($oPps->{Size}% $rhInfo->{_BIG_BLOCK_SIZE})? 1: 0)); | |
| 296 | } | |
| 297 | } | |
| 298 | } | |
| 299 | $iSmallLen = $iSBcnt * $rhInfo->{_SMALL_BLOCK_SIZE}; | |
| 300 | my $iSlCnt = int($rhInfo->{_BIG_BLOCK_SIZE}/ OLE::Storage_Lite::LongIntSize()); | |
| 301 | $iSBDcnt = int($iSBcnt / $iSlCnt)+ (($iSBcnt % $iSlCnt)? 1:0); | |
| 302 | $iBBcnt += (int($iSmallLen/ $rhInfo->{_BIG_BLOCK_SIZE}) + | |
| 303 | (( $iSmallLen% $rhInfo->{_BIG_BLOCK_SIZE})? 1: 0)); | |
| 304 | my $iCnt = scalar(@$raList); | |
| 305 | my $iBdCnt = $rhInfo->{_BIG_BLOCK_SIZE}/OLE::Storage_Lite::PpsSize(); | |
| 306 | $iPPScnt = (int($iCnt/$iBdCnt) + (($iCnt % $iBdCnt)? 1: 0)); | |
| 307 | ||
| 308 | return ($iSBDcnt, $iBBcnt, $iPPScnt); | |
| 309 | } | |
| 310 | #------------------------------------------------------------------------------ | |
| 311 | # _adjust2 (OLE::Storage_Lite::PPS::Root) | |
| 312 | #------------------------------------------------------------------------------ | |
| 313 | sub _adjust2($) { | |
| 314 | my($i2) = @_; | |
| 315 | my $iWk; | |
| 316 | $iWk = log($i2)/log(2); | |
| 317 | return ($iWk > int($iWk))? int($iWk)+1:$iWk; | |
| 318 | } | |
| 319 | #------------------------------------------------------------------------------ | |
| 320 | # _saveHeader (OLE::Storage_Lite::PPS::Root) | |
| 321 | #------------------------------------------------------------------------------ | |
| 322 | sub _saveHeader($$$$$) { | |
| 323 | my($oThis, $rhInfo, $iSBDcnt, $iBBcnt, $iPPScnt) = @_; | |
| 324 | my $FILE = $rhInfo->{_FILEH_}; | |
| 325 | ||
| 326 | #0. Calculate Basic Setting | |
| 327 | my $iBlCnt = $rhInfo->{_BIG_BLOCK_SIZE} / OLE::Storage_Lite::LongIntSize(); | |
| 328 | my $i1stBdL = ($rhInfo->{_BIG_BLOCK_SIZE} - 0x4C) / OLE::Storage_Lite::LongIntSize(); | |
| 329 | ||
| 330 | my $iBdExL = 0; | |
| 331 | my $iAll = $iBBcnt + $iPPScnt + $iSBDcnt; | |
| 332 | my $iAllW = $iAll; | |
| 333 | my $iBdCntW = int($iAllW / $iBlCnt) + (($iAllW % $iBlCnt)? 1: 0); | |
| 334 | my $iBdCnt = int(($iAll + $iBdCntW) / $iBlCnt) + ((($iAllW+$iBdCntW) % $iBlCnt)? 1: 0); | |
| 335 | my $i; | |
| 336 | ||
| 337 | #0.1 Calculate BD count | |
| 338 | if ($iBdCnt >$i1stBdL) { | |
| 339 | while(1) { | |
| 340 | $iBdExL++; | |
| 341 | $iAllW++; | |
| 342 | $iBdCntW = int($iAllW / $iBlCnt) + (($iAllW % $iBlCnt)? 1: 0); | |
| 343 | # $iBdCnt = int(($iAllW + $iBdCntW) / $iBlCnt) + ((($iAllW+$iBdCntW) % $iBlCnt)? 1: 0); | |
| 344 | $iBdCnt = int(($iAllW + $iBdCntW) / $iBlCnt) + 1; | |
| 345 | last if($iBdCnt <= ($iBdExL*$iBlCnt+ $i1stBdL)); | |
| 346 | } | |
| 347 | } | |
| 348 | ||
| 349 | #1.Save Header | |
| 350 | $FILE->print( | |
| 351 | "\xD0\xCF\x11\xE0\xA1\xB1\x1A\xE1" | |
| 352 | , "\x00\x00\x00\x00" x 4 | |
| 353 | , pack("v", 0x3b) | |
| 354 | , pack("v", 0x03) | |
| 355 | , pack("v", -2) | |
| 356 | , pack("v", 9) | |
| 357 | , pack("v", 6) | |
| 358 | , pack("v", 0) | |
| 359 | , "\x00\x00\x00\x00" x 2 | |
| 360 | , pack("V", $iBdCnt), | |
| 361 | , pack("V", $iBBcnt+$iSBDcnt), #ROOT START | |
| 362 | , pack("V", 0) | |
| 363 | , pack("V", 0x1000) | |
| 364 | , pack("V", 0) #Small Block Depot | |
| 365 | , pack("V", 1) | |
| 366 | ); | |
| 367 | #2. Extra BDList Start, Count | |
| 368 | if($iBdCnt < $i1stBdL) { | |
| 369 | $FILE->print( | |
| 370 | pack("V", -2), #Extra BDList Start | |
| 371 | pack("V", 0), #Extra BDList Count | |
| 372 | ); | |
| 373 | } | |
| 374 | else { | |
| 375 | $FILE->print( | |
| 376 | pack("V", $iAll+$iBdCnt), | |
| 377 | pack("V", $iBdExL), | |
| 378 | ); | |
| 379 | } | |
| 380 | ||
| 381 | #3. BDList | |
| 382 | for($i=0; $i<$i1stBdL and $i < $iBdCnt; $i++) { | |
| 383 | $FILE->print(pack("V", $iAll+$i)); | |
| 384 | } | |
| 385 | $FILE->print((pack("V", -1)) x($i1stBdL-$i)) if($i<$i1stBdL); | |
| 386 | } | |
| 387 | #------------------------------------------------------------------------------ | |
| 388 | # _saveBigData (OLE::Storage_Lite::PPS) | |
| 389 | #------------------------------------------------------------------------------ | |
| 390 | sub _saveBigData($$$$) { | |
| 391 | my($oThis, $iStBlk, $raList, $rhInfo) = @_; | |
| 392 | my $iRes = 0; | |
| 393 | my $FILE = $rhInfo->{_FILEH_}; | |
| 394 | ||
| 395 | #1.Write Big (ge 0x1000) Data into Block | |
| 396 | foreach my $oPps (@$raList) { | |
| 397 | if($oPps->{Type}!=OLE::Storage_Lite::PpsType_Dir()) { | |
| 398 | #print "PPS: $oPps DEF:", defined($oPps->{Data}), "\n"; | |
| 399 | $oPps->{Size} = $oPps->_DataLen(); #Mod | |
| 400 | if(($oPps->{Size} >= $rhInfo->{_SMALL_SIZE}) || | |
| 401 | (($oPps->{Type} == OLE::Storage_Lite::PpsType_Root()) && defined($oPps->{Data}))) { | |
| 402 | #1.1 Write Data | |
| 403 | #Check for update | |
| 404 | if($oPps->{_PPS_FILE}) { | |
| 405 | my $sBuff; | |
| 406 | my $iLen = 0; | |
| 407 | $oPps->{_PPS_FILE}->seek(0, 0); #To The Top | |
| 408 | while($oPps->{_PPS_FILE}->read($sBuff, 4096)) { | |
| 409 | $iLen += length($sBuff); | |
| 410 | $FILE->print($sBuff); #Check for update | |
| 411 | } | |
| 412 | } | |
| 413 | else { | |
| 414 | $FILE->print($oPps->{Data}); | |
| 415 | } | |
| 416 | $FILE->print( | |
| 417 | "\x00" x | |
| 418 | ($rhInfo->{_BIG_BLOCK_SIZE} - | |
| 419 | ($oPps->{Size} % $rhInfo->{_BIG_BLOCK_SIZE})) | |
| 420 | ) if ($oPps->{Size} % $rhInfo->{_BIG_BLOCK_SIZE}); | |
| 421 | #1.2 Set For PPS | |
| 422 | $oPps->{StartBlock} = $$iStBlk; | |
| 423 | $$iStBlk += | |
| 424 | (int($oPps->{Size}/ $rhInfo->{_BIG_BLOCK_SIZE}) + | |
| 425 | (($oPps->{Size}% $rhInfo->{_BIG_BLOCK_SIZE})? 1: 0)); | |
| 426 | } | |
| 427 | } | |
| 428 | } | |
| 429 | } | |
| 430 | #------------------------------------------------------------------------------ | |
| 431 | # _savePps (OLE::Storage_Lite::PPS::Root) | |
| 432 | #------------------------------------------------------------------------------ | |
| 433 | sub _savePps($$$) | |
| 434 | { | |
| 435 | my($oThis, $raList, $rhInfo) = @_; | |
| 436 | #0. Initial | |
| 437 | my $FILE = $rhInfo->{_FILEH_}; | |
| 438 | #2. Save PPS | |
| 439 | foreach my $oItem (@$raList) { | |
| 440 | $oItem->_savePpsWk($rhInfo); | |
| 441 | } | |
| 442 | #3. Adjust for Block | |
| 443 | my $iCnt = scalar(@$raList); | |
| 444 | my $iBCnt = $rhInfo->{_BIG_BLOCK_SIZE} / $rhInfo->{_PPS_SIZE}; | |
| 445 | $FILE->print("\x00" x (($iBCnt - ($iCnt % $iBCnt)) * $rhInfo->{_PPS_SIZE})) | |
| 446 | if($iCnt % $iBCnt); | |
| 447 | return int($iCnt / $iBCnt) + (($iCnt % $iBCnt)? 1: 0); | |
| 448 | } | |
| 449 | #------------------------------------------------------------------------------ | |
| 450 | # _savePpsSetPnt2 (OLE::Storage_Lite::PPS::Root) | |
| 451 | # For Test | |
| 452 | #------------------------------------------------------------------------------ | |
| 453 | sub _savePpsSetPnt2($$$) | |
| 454 | { | |
| 455 | my($aThis, $raList, $rhInfo) = @_; | |
| 456 | #1. make Array as Children-Relations | |
| 457 | #1.1 if No Children | |
| 458 | if($#$aThis < 0) { | |
| 459 | return 0xFFFFFFFF; | |
| 460 | } | |
| 461 | elsif($#$aThis == 0) { | |
| 462 | #1.2 Just Only one | |
| 463 | push @$raList, $aThis->[0]; | |
| 464 | $aThis->[0]->{No} = $#$raList; | |
| 465 | $aThis->[0]->{PrevPps} = 0xFFFFFFFF; | |
| 466 | $aThis->[0]->{NextPps} = 0xFFFFFFFF; | |
| 467 | $aThis->[0]->{DirPps} = _savePpsSetPnt2($aThis->[0]->{Child}, $raList, $rhInfo); | |
| 468 | return $aThis->[0]->{No}; | |
| 469 | } | |
| 470 | else { | |
| 471 | #1.3 Array | |
| 472 | my $iCnt = $#$aThis + 1; | |
| 473 | #1.3.1 Define Center | |
| 474 | my $iPos = 0; #int($iCnt/ 2); #$iCnt | |
| 475 | ||
| 476 | my @aWk = @$aThis; | |
| 477 | my @aPrev = ($#$aThis > 1)? splice(@aWk, 1, 1) : (); #$iPos); | |
| 478 | my @aNext = splice(@aWk, 1); #, $iCnt - $iPos -1); | |
| 479 | $aThis->[$iPos]->{PrevPps} = _savePpsSetPnt2( | |
| 480 | \@aPrev, $raList, $rhInfo); | |
| 481 | push @$raList, $aThis->[$iPos]; | |
| 482 | $aThis->[$iPos]->{No} = $#$raList; | |
| 483 | ||
| 484 | #1.3.2 Devide a array into Previous,Next | |
| 485 | $aThis->[$iPos]->{NextPps} = _savePpsSetPnt2( | |
| 486 | \@aNext, $raList, $rhInfo); | |
| 487 | $aThis->[$iPos]->{DirPps} = _savePpsSetPnt2($aThis->[$iPos]->{Child}, $raList, $rhInfo); | |
| 488 | return $aThis->[$iPos]->{No}; | |
| 489 | } | |
| 490 | } | |
| 491 | #------------------------------------------------------------------------------ | |
| 492 | # _savePpsSetPnt2 (OLE::Storage_Lite::PPS::Root) | |
| 493 | # For Test | |
| 494 | #------------------------------------------------------------------------------ | |
| 495 | sub _savePpsSetPnt2s($$$) | |
| 496 | { | |
| 497 | my($aThis, $raList, $rhInfo) = @_; | |
| 498 | #1. make Array as Children-Relations | |
| 499 | #1.1 if No Children | |
| 500 | if($#$aThis < 0) { | |
| 501 | return 0xFFFFFFFF; | |
| 502 | } | |
| 503 | elsif($#$aThis == 0) { | |
| 504 | #1.2 Just Only one | |
| 505 | push @$raList, $aThis->[0]; | |
| 506 | $aThis->[0]->{No} = $#$raList; | |
| 507 | $aThis->[0]->{PrevPps} = 0xFFFFFFFF; | |
| 508 | $aThis->[0]->{NextPps} = 0xFFFFFFFF; | |
| 509 | $aThis->[0]->{DirPps} = _savePpsSetPnt2($aThis->[0]->{Child}, $raList, $rhInfo); | |
| 510 | return $aThis->[0]->{No}; | |
| 511 | } | |
| 512 | else { | |
| 513 | #1.3 Array | |
| 514 | my $iCnt = $#$aThis + 1; | |
| 515 | #1.3.1 Define Center | |
| 516 | my $iPos = 0; #int($iCnt/ 2); #$iCnt | |
| 517 | push @$raList, $aThis->[$iPos]; | |
| 518 | $aThis->[$iPos]->{No} = $#$raList; | |
| 519 | my @aWk = @$aThis; | |
| 520 | #1.3.2 Devide a array into Previous,Next | |
| 521 | my @aPrev = splice(@aWk, 0, $iPos); | |
| 522 | my @aNext = splice(@aWk, 1, $iCnt - $iPos -1); | |
| 523 | $aThis->[$iPos]->{PrevPps} = _savePpsSetPnt2( | |
| 524 | \@aPrev, $raList, $rhInfo); | |
| 525 | $aThis->[$iPos]->{NextPps} = _savePpsSetPnt2( | |
| 526 | \@aNext, $raList, $rhInfo); | |
| 527 | $aThis->[$iPos]->{DirPps} = _savePpsSetPnt2($aThis->[$iPos]->{Child}, $raList, $rhInfo); | |
| 528 | return $aThis->[$iPos]->{No}; | |
| 529 | } | |
| 530 | } | |
| 531 | #------------------------------------------------------------------------------ | |
| 532 | # _savePpsSetPnt (OLE::Storage_Lite::PPS::Root) | |
| 533 | #------------------------------------------------------------------------------ | |
| 534 | sub _savePpsSetPnt($$$) | |
| 535 | { | |
| 536 | my($aThis, $raList, $rhInfo) = @_; | |
| 537 | #1. make Array as Children-Relations | |
| 538 | #1.1 if No Children | |
| 539 | if($#$aThis < 0) { | |
| 540 | return 0xFFFFFFFF; | |
| 541 | } | |
| 542 | elsif($#$aThis == 0) { | |
| 543 | #1.2 Just Only one | |
| 544 | push @$raList, $aThis->[0]; | |
| 545 | $aThis->[0]->{No} = $#$raList; | |
| 546 | $aThis->[0]->{PrevPps} = 0xFFFFFFFF; | |
| 547 | $aThis->[0]->{NextPps} = 0xFFFFFFFF; | |
| 548 | $aThis->[0]->{DirPps} = _savePpsSetPnt($aThis->[0]->{Child}, $raList, $rhInfo); | |
| 549 | return $aThis->[0]->{No}; | |
| 550 | } | |
| 551 | else { | |
| 552 | #1.3 Array | |
| 553 | my $iCnt = $#$aThis + 1; | |
| 554 | #1.3.1 Define Center | |
| 555 | my $iPos = int($iCnt/ 2); #$iCnt | |
| 556 | push @$raList, $aThis->[$iPos]; | |
| 557 | $aThis->[$iPos]->{No} = $#$raList; | |
| 558 | my @aWk = @$aThis; | |
| 559 | #1.3.2 Devide a array into Previous,Next | |
| 560 | my @aPrev = splice(@aWk, 0, $iPos); | |
| 561 | my @aNext = splice(@aWk, 1, $iCnt - $iPos -1); | |
| 562 | $aThis->[$iPos]->{PrevPps} = _savePpsSetPnt( | |
| 563 | \@aPrev, $raList, $rhInfo); | |
| 564 | $aThis->[$iPos]->{NextPps} = _savePpsSetPnt( | |
| 565 | \@aNext, $raList, $rhInfo); | |
| 566 | $aThis->[$iPos]->{DirPps} = _savePpsSetPnt($aThis->[$iPos]->{Child}, $raList, $rhInfo); | |
| 567 | return $aThis->[$iPos]->{No}; | |
| 568 | } | |
| 569 | } | |
| 570 | #------------------------------------------------------------------------------ | |
| 571 | # _savePpsSetPnt (OLE::Storage_Lite::PPS::Root) | |
| 572 | #------------------------------------------------------------------------------ | |
| 573 | sub _savePpsSetPnt1($$$) | |
| 574 | { | |
| 575 | my($aThis, $raList, $rhInfo) = @_; | |
| 576 | #1. make Array as Children-Relations | |
| 577 | #1.1 if No Children | |
| 578 | if($#$aThis < 0) { | |
| 579 | return 0xFFFFFFFF; | |
| 580 | } | |
| 581 | elsif($#$aThis == 0) { | |
| 582 | #1.2 Just Only one | |
| 583 | push @$raList, $aThis->[0]; | |
| 584 | $aThis->[0]->{No} = $#$raList; | |
| 585 | $aThis->[0]->{PrevPps} = 0xFFFFFFFF; | |
| 586 | $aThis->[0]->{NextPps} = 0xFFFFFFFF; | |
| 587 | $aThis->[0]->{DirPps} = _savePpsSetPnt($aThis->[0]->{Child}, $raList, $rhInfo); | |
| 588 | return $aThis->[0]->{No}; | |
| 589 | } | |
| 590 | else { | |
| 591 | #1.3 Array | |
| 592 | my $iCnt = $#$aThis + 1; | |
| 593 | #1.3.1 Define Center | |
| 594 | my $iPos = int($iCnt/ 2); #$iCnt | |
| 595 | push @$raList, $aThis->[$iPos]; | |
| 596 | $aThis->[$iPos]->{No} = $#$raList; | |
| 597 | my @aWk = @$aThis; | |
| 598 | #1.3.2 Devide a array into Previous,Next | |
| 599 | my @aPrev = splice(@aWk, 0, $iPos); | |
| 600 | my @aNext = splice(@aWk, 1, $iCnt - $iPos -1); | |
| 601 | $aThis->[$iPos]->{PrevPps} = _savePpsSetPnt( | |
| 602 | \@aPrev, $raList, $rhInfo); | |
| 603 | $aThis->[$iPos]->{NextPps} = _savePpsSetPnt( | |
| 604 | \@aNext, $raList, $rhInfo); | |
| 605 | $aThis->[$iPos]->{DirPps} = _savePpsSetPnt($aThis->[$iPos]->{Child}, $raList, $rhInfo); | |
| 606 | return $aThis->[$iPos]->{No}; | |
| 607 | } | |
| 608 | } | |
| 609 | #------------------------------------------------------------------------------ | |
| 610 | # _saveBbd (OLE::Storage_Lite) | |
| 611 | #------------------------------------------------------------------------------ | |
| 612 | sub _saveBbd($$$$) | |
| 613 | { | |
| 614 | my($oThis, $iSbdSize, $iBsize, $iPpsCnt, $rhInfo) = @_; | |
| 615 | my $FILE = $rhInfo->{_FILEH_}; | |
| 616 | #0. Calculate Basic Setting | |
| 617 | my $iBbCnt = $rhInfo->{_BIG_BLOCK_SIZE} / OLE::Storage_Lite::LongIntSize(); | |
| 618 | my $i1stBdL = ($rhInfo->{_BIG_BLOCK_SIZE} - 0x4C) / OLE::Storage_Lite::LongIntSize(); | |
| 619 | ||
| 620 | my $iBdExL = 0; | |
| 621 | my $iAll = $iBsize + $iPpsCnt + $iSbdSize; | |
| 622 | my $iAllW = $iAll; | |
| 623 | my $iBdCntW = int($iAllW / $iBbCnt) + (($iAllW % $iBbCnt)? 1: 0); | |
| 624 | my $iBdCnt = int(($iAll + $iBdCntW) / $iBbCnt) + ((($iAllW+$iBdCntW) % $iBbCnt)? 1: 0); | |
| 625 | my $i; | |
| 626 | #0.1 Calculate BD count | |
| 627 | if ($iBdCnt >$i1stBdL) { | |
| 628 | while(1) { | |
| 629 | $iBdExL++; | |
| 630 | $iAllW++; | |
| 631 | $iBdCntW = int($iAllW / $iBbCnt) + (($iAllW % $iBbCnt)? 1: 0); | |
| 632 | $iBdCnt = int(($iAllW + $iBdCntW) / $iBbCnt) + ((($iAllW+$iBdCntW) % $iBbCnt)? 1: 0); | |
| 633 | last if($iBdCnt <= ($iBdExL*$iBbCnt+ $i1stBdL)); | |
| 634 | } | |
| 635 | } | |
| 636 | ||
| 637 | #1. Making BD | |
| 638 | #1.1 Set for SBD | |
| 639 | if($iSbdSize > 0) { | |
| 640 | for ($i = 0; $i<($iSbdSize-1); $i++) { | |
| 641 | $FILE->print(pack("V", $i+1)); | |
| 642 | } | |
| 643 | $FILE->print(pack("V", -2)); | |
| 644 | } | |
| 645 | #1.2 Set for B | |
| 646 | for ($i = 0; $i<($iBsize-1); $i++) { | |
| 647 | $FILE->print(pack("V", $i+$iSbdSize+1)); | |
| 648 | } | |
| 649 | $FILE->print(pack("V", -2)); | |
| 650 | ||
| 651 | #1.3 Set for PPS | |
| 652 | for ($i = 0; $i<($iPpsCnt-1); $i++) { | |
| 653 | $FILE->print(pack("V", $i+$iSbdSize+$iBsize+1)); | |
| 654 | } | |
| 655 | $FILE->print(pack("V", -2)); | |
| 656 | #1.4 Set for BBD itself ( 0xFFFFFFFD : BBD) | |
| 657 | for($i=0; $i<$iBdCnt;$i++) { | |
| 658 | $FILE->print(pack("V", 0xFFFFFFFD)); | |
| 659 | } | |
| 660 | #1.5 Set for ExtraBDList | |
| 661 | for($i=0; $i<$iBdExL;$i++) { | |
| 662 | $FILE->print(pack("V", 0xFFFFFFFC)); | |
| 663 | } | |
| 664 | #1.6 Adjust for Block | |
| 665 | $FILE->print(pack("V", -1) x ($iBbCnt - (($iAllW + $iBdCnt) % $iBbCnt))) | |
| 666 | if(($iAllW + $iBdCnt) % $iBbCnt); | |
| 667 | ||
| 668 | #2.Extra BDList | |
| 669 | if($iBdCnt > $i1stBdL) { | |
| 670 | my $iN=0; | |
| 671 | my $iNb=0; | |
| 672 | for($i=$i1stBdL;$i<$iBdCnt; $i++, $iN++) { | |
| 673 | if($iN>=($iBbCnt-1)) { | |
| 674 | $iN = 0; | |
| 675 | $iNb++; | |
| 676 | $FILE->print(pack("V", $iAll+$iBdCnt+$iNb)); | |
| 677 | } | |
| 678 | $FILE->print(pack("V", $iBsize+$iSbdSize+$iPpsCnt+$i)); | |
| 679 | } | |
| 680 | $FILE->print(pack("V", -1) x (($iBbCnt-1) - (($iBdCnt-$i1stBdL) % ($iBbCnt-1)))) | |
| 681 | if(($iBdCnt-$i1stBdL) % ($iBbCnt-1)); | |
| 682 | $FILE->print(pack("V", -2)); | |
| 683 | } | |
| 684 | } | |
| 685 | ||
| 686 | #////////////////////////////////////////////////////////////////////////////// | |
| 687 | # OLE::Storage_Lite::PPS::File Object | |
| 688 | #////////////////////////////////////////////////////////////////////////////// | |
| 689 | #============================================================================== | |
| 690 | # OLE::Storage_Lite::PPS::File | |
| 691 | #============================================================================== | |
| 692 | package OLE::Storage_Lite::PPS::File; | |
| 693 | require Exporter; | |
| 694 | use strict; | |
| 695 | use vars qw($VERSION @ISA); | |
| 696 | @ISA = qw(OLE::Storage_Lite::PPS Exporter); | |
| 697 | $VERSION = '0.11'; | |
| 698 | #------------------------------------------------------------------------------ | |
| 699 | # new (OLE::Storage_Lite::PPS::File) | |
| 700 | #------------------------------------------------------------------------------ | |
| 701 | sub new ($$$) { | |
| 702 | my($sClass, $sNm, $sData) = @_; | |
| 703 | OLE::Storage_Lite::PPS::_new( | |
| 704 | $sClass, | |
| 705 | undef, | |
| 706 | $sNm, | |
| 707 | 2, | |
| 708 | undef, | |
| 709 | undef, | |
| 710 | undef, | |
| 711 | undef, | |
| 712 | undef, | |
| 713 | undef, | |
| 714 | undef, | |
| 715 | $sData, | |
| 716 | undef); | |
| 717 | } | |
| 718 | #------------------------------------------------------------------------------ | |
| 719 | # newFile (OLE::Storage_Lite::PPS::File) | |
| 720 | #------------------------------------------------------------------------------ | |
| 721 | sub newFile ($$;$) { | |
| 722 | my($sClass, $sNm, $sFile) = @_; | |
| 723 | my $oSelf = | |
| 724 | OLE::Storage_Lite::PPS::_new( | |
| 725 | $sClass, | |
| 726 | undef, | |
| 727 | $sNm, | |
| 728 | 2, | |
| 729 | undef, | |
| 730 | undef, | |
| 731 | undef, | |
| 732 | undef, | |
| 733 | undef, | |
| 734 | undef, | |
| 735 | undef, | |
| 736 | '', | |
| 737 | undef); | |
| 738 | # | |
| 739 | if((!defined($sFile)) or ($sFile eq '')) { | |
| 740 | $oSelf->{_PPS_FILE} = IO::File->new_tmpfile(); | |
| 741 | } | |
| 742 | elsif(UNIVERSAL::isa($sFile, 'IO::Handle')) { | |
| 743 | $oSelf->{_PPS_FILE} = $sFile; | |
| 744 | } | |
| 745 | elsif(!ref($sFile)) { | |
| 746 | #File Name | |
| 747 | $oSelf->{_PPS_FILE} = new IO::File; | |
| 748 | return undef unless($oSelf->{_PPS_FILE}); | |
| 749 | $oSelf->{_PPS_FILE}->open("$sFile", "r+") || return undef; | |
| 750 | } | |
| 751 | else { | |
| 752 | return undef; | |
| 753 | } | |
| 754 | if($oSelf->{_PPS_FILE}) { | |
| 755 | $oSelf->{_PPS_FILE}->seek(0, 2); | |
| 756 | binmode($oSelf->{_PPS_FILE}); | |
| 757 | $oSelf->{_PPS_FILE}->autoflush(1); | |
| 758 | } | |
| 759 | return $oSelf; | |
| 760 | } | |
| 761 | #------------------------------------------------------------------------------ | |
| 762 | # append (OLE::Storage_Lite::PPS::File) | |
| 763 | #------------------------------------------------------------------------------ | |
| 764 | sub append ($$) { | |
| 765 | my($oSelf, $sData) = @_; | |
| 766 | if($oSelf->{_PPS_FILE}) { | |
| 767 | $oSelf->{_PPS_FILE}->print($sData); | |
| 768 | } | |
| 769 | else { | |
| 770 | $oSelf->{Data} .= $sData; | |
| 771 | } | |
| 772 | } | |
| 773 | ||
| 774 | #////////////////////////////////////////////////////////////////////////////// | |
| 775 | # OLE::Storage_Lite::PPS::Dir Object | |
| 776 | #////////////////////////////////////////////////////////////////////////////// | |
| 777 | #------------------------------------------------------------------------------ | |
| 778 | # new (OLE::Storage_Lite::PPS::Dir) | |
| 779 | #------------------------------------------------------------------------------ | |
| 780 | package OLE::Storage_Lite::PPS::Dir; | |
| 781 | require Exporter; | |
| 782 | use strict; | |
| 783 | use vars qw($VERSION @ISA); | |
| 784 | @ISA = qw(OLE::Storage_Lite::PPS Exporter); | |
| 785 | $VERSION = '0.11'; | |
| 786 | sub new ($$;$$$) { | |
| 787 | my($sClass, $sName, $raTime1st, $raTime2nd, $raChild) = @_; | |
| 788 | OLE::Storage_Lite::PPS::_new( | |
| 789 | $sClass, | |
| 790 | undef, | |
| 791 | $sName, | |
| 792 | 1, | |
| 793 | undef, | |
| 794 | undef, | |
| 795 | undef, | |
| 796 | $raTime1st, | |
| 797 | $raTime2nd, | |
| 798 | undef, | |
| 799 | undef, | |
| 800 | undef, | |
| 801 | $raChild); | |
| 802 | } | |
| 803 | #============================================================================== | |
| 804 | # OLE::Storage_Lite | |
| 805 | #============================================================================== | |
| 806 | package OLE::Storage_Lite; | |
| 807 | require Exporter; | |
| 808 | use strict; | |
| 809 | use IO::File; | |
| 810 | use IO::Scalar; | |
| 811 | use vars qw($VERSION @ISA @EXPORT); | |
| 812 | @ISA = qw(Exporter); | |
| 813 | $VERSION = '0.11'; | |
| 814 | sub _getPpsSearch($$$$$;$); | |
| 815 | sub _getPpsTree($$$;$); | |
| 816 | #------------------------------------------------------------------------------ | |
| 817 | # Const for OLE::Storage_Lite | |
| 818 | #------------------------------------------------------------------------------ | |
| 819 | #0. Constants | |
| 820 | sub PpsType_Root {5}; | |
| 821 | sub PpsType_Dir {1}; | |
| 822 | sub PpsType_File {2}; | |
| 823 | sub DataSizeSmall{0x1000}; | |
| 824 | sub LongIntSize {4}; | |
| 825 | sub PpsSize {0x80}; | |
| 826 | #------------------------------------------------------------------------------ | |
| 827 | # new OLE::Storage_Lite | |
| 828 | #------------------------------------------------------------------------------ | |
| 829 | sub new($$) { | |
| 830 | my($sClass, $sFile) = @_; | |
| 831 | my $oThis = { | |
| 832 | _FILE => $sFile, | |
| 833 | }; | |
| 834 | bless $oThis; | |
| 835 | return $oThis; | |
| 836 | } | |
| 837 | #------------------------------------------------------------------------------ | |
| 838 | # getPpsTree: OLE::Storage_Lite | |
| 839 | #------------------------------------------------------------------------------ | |
| 840 | sub getPpsTree($;$) | |
| 841 | { | |
| 842 | my($oThis, $bData) = @_; | |
| 843 | #0.Init | |
| 844 | my $rhInfo = _initParse($oThis->{_FILE}); | |
| 845 | return undef unless($rhInfo); | |
| 846 | #1. Get Data | |
| 847 | my ($oPps) = _getPpsTree(0, $rhInfo, $bData); | |
| 848 | close(IN); | |
| 849 | return $oPps; | |
| 850 | } | |
| 851 | #------------------------------------------------------------------------------ | |
| 852 | # getSearch: OLE::Storage_Lite | |
| 853 | #------------------------------------------------------------------------------ | |
| 854 | sub getPpsSearch($$;$$) | |
| 855 | { | |
| 856 | my($oThis, $raName, $bData, $iCase) = @_; | |
| 857 | #0.Init | |
| 858 | my $rhInfo = _initParse($oThis->{_FILE}); | |
| 859 | return undef unless($rhInfo); | |
| 860 | #1. Get Data | |
| 861 | my @aList = _getPpsSearch(0, $rhInfo, $raName, $bData, $iCase); | |
| 862 | close(IN); | |
| 863 | return @aList; | |
| 864 | } | |
| 865 | #------------------------------------------------------------------------------ | |
| 866 | # getNthPps: OLE::Storage_Lite | |
| 867 | #------------------------------------------------------------------------------ | |
| 868 | sub getNthPps($$;$) | |
| 869 | { | |
| 870 | my($oThis, $iNo, $bData) = @_; | |
| 871 | #0.Init | |
| 872 | my $rhInfo = _initParse($oThis->{_FILE}); | |
| 873 | return undef unless($rhInfo); | |
| 874 | #1. Get Data | |
| 875 | my $oPps = _getNthPps($iNo, $rhInfo, $bData); | |
| 876 | close IN; | |
| 877 | return $oPps; | |
| 878 | } | |
| 879 | #------------------------------------------------------------------------------ | |
| 880 | # _initParse: OLE::Storage_Lite | |
| 881 | #------------------------------------------------------------------------------ | |
| 882 | sub _initParse($) { | |
| 883 | my($sFile)=@_; | |
| 884 | my $oIo; | |
| 885 | #1. $sFile is Ref of scalar | |
| 886 | if(ref($sFile) eq 'SCALAR') { | |
| 887 | $oIo = new IO::Scalar; | |
| 888 | $oIo->open($sFile); | |
| 889 | } | |
| 890 | #2. $sFile is a IO::Handle object | |
| 891 | elsif(UNIVERSAL::isa($sFile, 'IO::Handle')) { | |
| 892 | $oIo = $sFile; | |
| 893 | binmode($oIo); | |
| 894 | } | |
| 895 | #3. $sFile is a simple filename string | |
| 896 | elsif(!ref($sFile)) { | |
| 897 | $oIo = new IO::File; | |
| 898 | $oIo->open("<$sFile") || return undef; | |
| 899 | binmode($oIo); | |
| 900 | } | |
| 901 | #4. Others | |
| 902 | else { | |
| 903 | return undef; | |
| 904 | } | |
| 905 | return _getHeaderInfo($oIo); | |
| 906 | } | |
| 907 | #------------------------------------------------------------------------------ | |
| 908 | # _getPpsTree: OLE::Storage_Lite | |
| 909 | #------------------------------------------------------------------------------ | |
| 910 | sub _getPpsTree($$$;$) { | |
| 911 | my($iNo, $rhInfo, $bData, $raDone) = @_; | |
| 912 | if(defined($raDone)) { | |
| 913 | return () if(grep {$_ ==$iNo} @$raDone); | |
| 914 | } | |
| 915 | else { | |
| 916 | $raDone=[]; | |
| 917 | } | |
| 918 | push @$raDone, $iNo; | |
| 919 | ||
| 920 | my $iRootBlock = $rhInfo->{_ROOT_START} ; | |
| 921 | #1. Get Information about itself | |
| 922 | my $oPps = _getNthPps($iNo, $rhInfo, $bData); | |
| 923 | #2. Child | |
| 924 | if($oPps->{DirPps} != 0xFFFFFFFF) { | |
| 925 | my @aChildL = _getPpsTree($oPps->{DirPps}, $rhInfo, $bData, $raDone); | |
| 926 | $oPps->{Child} = \@aChildL; | |
| 927 | } | |
| 928 | else { | |
| 929 | $oPps->{Child} = undef; | |
| 930 | } | |
| 931 | #3. Previous,Next PPSs | |
| 932 | my @aList = (); | |
| 933 | push @aList, _getPpsTree($oPps->{PrevPps}, $rhInfo, $bData, $raDone) | |
| 934 | if($oPps->{PrevPps} != 0xFFFFFFFF); | |
| 935 | push @aList, $oPps; | |
| 936 | push @aList, _getPpsTree($oPps->{NextPps}, $rhInfo, $bData, $raDone) | |
| 937 | if($oPps->{NextPps} != 0xFFFFFFFF); | |
| 938 | return @aList; | |
| 939 | } | |
| 940 | #------------------------------------------------------------------------------ | |
| 941 | # _getPpsSearch: OLE::Storage_Lite | |
| 942 | #------------------------------------------------------------------------------ | |
| 943 | sub _getPpsSearch($$$$$;$) { | |
| 944 | my($iNo, $rhInfo, $raName, $bData, $iCase, $raDone) = @_; | |
| 945 | my $iRootBlock = $rhInfo->{_ROOT_START} ; | |
| 946 | my @aRes; | |
| 947 | #1. Check it self | |
| 948 | if(defined($raDone)) { | |
| 949 | return () if(grep {$_==$iNo} @$raDone); | |
| 950 | } | |
| 951 | else { | |
| 952 | $raDone=[]; | |
| 953 | } | |
| 954 | push @$raDone, $iNo; | |
| 955 | my $oPps = _getNthPps($iNo, $rhInfo, undef); | |
| 956 | # if(grep($_ eq $oPps->{Name}, @$raName)) { | |
| 957 | if(($iCase && (grep(/^\Q$oPps->{Name}\E$/i, @$raName))) || | |
| 958 | (grep($_ eq $oPps->{Name}, @$raName))) { | |
| 959 | $oPps = _getNthPps($iNo, $rhInfo, $bData) if ($bData); | |
| 960 | @aRes = ($oPps); | |
| 961 | } | |
| 962 | else { | |
| 963 | @aRes = (); | |
| 964 | } | |
| 965 | #2. Check Child, Previous, Next PPSs | |
| 966 | push @aRes, _getPpsSearch($oPps->{DirPps}, $rhInfo, $raName, $bData, $iCase, $raDone) | |
| 967 | if($oPps->{DirPps} != 0xFFFFFFFF) ; | |
| 968 | push @aRes, _getPpsSearch($oPps->{PrevPps}, $rhInfo, $raName, $bData, $iCase, $raDone) | |
| 969 | if($oPps->{PrevPps} != 0xFFFFFFFF ); | |
| 970 | push @aRes, _getPpsSearch($oPps->{NextPps}, $rhInfo, $raName, $bData, $iCase, $raDone) | |
| 971 | if($oPps->{NextPps} != 0xFFFFFFFF); | |
| 972 | return @aRes; | |
| 973 | } | |
| 974 | #=================================================================== | |
| 975 | # Get Header Info (BASE Informain about that file) | |
| 976 | #=================================================================== | |
| 977 | sub _getHeaderInfo($){ | |
| 978 | my($FILE) = @_; | |
| 979 | my($iWk); | |
| 980 | my $rhInfo = {}; | |
| 981 | $rhInfo->{_FILEH_} = $FILE; | |
| 982 | my $sWk; | |
| 983 | #0. Check ID | |
| 984 | $rhInfo->{_FILEH_}->seek(0, 0); | |
| 985 | $rhInfo->{_FILEH_}->read($sWk, 8); | |
| 986 | return undef unless($sWk eq "\xD0\xCF\x11\xE0\xA1\xB1\x1A\xE1"); | |
| 987 | #BIG BLOCK SIZE | |
| 988 | $iWk = _getInfoFromFile($rhInfo->{_FILEH_}, 0x1E, 2, "v"); | |
| 989 | return undef unless(defined($iWk)); | |
| 990 | $rhInfo->{_BIG_BLOCK_SIZE} = 2 ** $iWk; | |
| 991 | #SMALL BLOCK SIZE | |
| 992 | $iWk = _getInfoFromFile($rhInfo->{_FILEH_}, 0x20, 2, "v"); | |
| 993 | return undef unless(defined($iWk)); | |
| 994 | $rhInfo->{_SMALL_BLOCK_SIZE} = 2 ** $iWk; | |
| 995 | #BDB Count | |
| 996 | $iWk = _getInfoFromFile($rhInfo->{_FILEH_}, 0x2C, 4, "V"); | |
| 997 | return undef unless(defined($iWk)); | |
| 998 | $rhInfo->{_BDB_COUNT} = $iWk; | |
| 999 | #START BLOCK | |
| 1000 | $iWk = _getInfoFromFile($rhInfo->{_FILEH_}, 0x30, 4, "V"); | |
| 1001 | return undef unless(defined($iWk)); | |
| 1002 | $rhInfo->{_ROOT_START} = $iWk; | |
| 1003 | #MIN SIZE OF BB | |
| 1004 | # $iWk = _getInfoFromFile($rhInfo->{_FILEH_}, 0x38, 4, "V"); | |
| 1005 | # return undef unless(defined($iWk)); | |
| 1006 | # $rhInfo->{_MIN_SIZE_BB} = $iWk; | |
| 1007 | #SMALL BD START | |
| 1008 | $iWk = _getInfoFromFile($rhInfo->{_FILEH_}, 0x3C, 4, "V"); | |
| 1009 | return undef unless(defined($iWk)); | |
| 1010 | $rhInfo->{_SBD_START} = $iWk; | |
| 1011 | #SMALL BD COUNT | |
| 1012 | $iWk = _getInfoFromFile($rhInfo->{_FILEH_}, 0x40, 4, "V"); | |
| 1013 | return undef unless(defined($iWk)); | |
| 1014 | $rhInfo->{_SBD_COUNT} = $iWk; | |
| 1015 | #EXTRA BBD START | |
| 1016 | $iWk = _getInfoFromFile($rhInfo->{_FILEH_}, 0x44, 4, "V"); | |
| 1017 | return undef unless(defined($iWk)); | |
| 1018 | $rhInfo->{_EXTRA_BBD_START} = $iWk; | |
| 1019 | #EXTRA BD COUNT | |
| 1020 | $iWk = _getInfoFromFile($rhInfo->{_FILEH_}, 0x48, 4, "V"); | |
| 1021 | return undef unless(defined($iWk)); | |
| 1022 | $rhInfo->{_EXTRA_BBD_COUNT} = $iWk; | |
| 1023 | #GET BBD INFO | |
| 1024 | $rhInfo->{_BBD_INFO}= _getBbdInfo($rhInfo); | |
| 1025 | #GET ROOT PPS | |
| 1026 | my $oRoot = _getNthPps(0, $rhInfo, undef); | |
| 1027 | $rhInfo->{_SB_START} = $oRoot->{StartBlock}; | |
| 1028 | $rhInfo->{_SB_SIZE} = $oRoot->{Size}; | |
| 1029 | return $rhInfo; | |
| 1030 | } | |
| 1031 | #------------------------------------------------------------------------------ | |
| 1032 | # _getInfoFromFile | |
| 1033 | #------------------------------------------------------------------------------ | |
| 1034 | sub _getInfoFromFile($$$$) { | |
| 1035 | my($FILE, $iPos, $iLen, $sFmt) =@_; | |
| 1036 | my($sWk); | |
| 1037 | return undef unless($FILE); | |
| 1038 | return undef if($FILE->seek($iPos, 0)==0); | |
| 1039 | return undef if($FILE->read($sWk, $iLen)!=$iLen); | |
| 1040 | return unpack($sFmt, $sWk); | |
| 1041 | } | |
| 1042 | #------------------------------------------------------------------------------ | |
| 1043 | # _getBbdInfo | |
| 1044 | #------------------------------------------------------------------------------ | |
| 1045 | sub _getBbdInfo($) { | |
| 1046 | my($rhInfo) =@_; | |
| 1047 | my @aBdList = (); | |
| 1048 | my $iBdbCnt = $rhInfo->{_BDB_COUNT}; | |
| 1049 | my $iGetCnt; | |
| 1050 | my $sWk; | |
| 1051 | my $i1stCnt = int(($rhInfo->{_BIG_BLOCK_SIZE} - 0x4C) / OLE::Storage_Lite::LongIntSize()); | |
| 1052 | my $iBdlCnt = int($rhInfo->{_BIG_BLOCK_SIZE} / OLE::Storage_Lite::LongIntSize()) - 1; | |
| 1053 | ||
| 1054 | #1. 1st BDlist | |
| 1055 | $rhInfo->{_FILEH_}->seek(0x4C, 0); | |
| 1056 | $iGetCnt = ($iBdbCnt < $i1stCnt)? $iBdbCnt: $i1stCnt; | |
| 1057 | $rhInfo->{_FILEH_}->read($sWk, OLE::Storage_Lite::LongIntSize()*$iGetCnt); | |
| 1058 | push @aBdList, unpack("V$iGetCnt", $sWk); | |
| 1059 | $iBdbCnt -= $iGetCnt; | |
| 1060 | #2. Extra BDList | |
| 1061 | my $iBlock = $rhInfo->{_EXTRA_BBD_START}; | |
| 1062 | while(($iBdbCnt> 0) && _isNormalBlock($iBlock)){ | |
| 1063 | _setFilePos($iBlock, 0, $rhInfo); | |
| 1064 | $iGetCnt= ($iBdbCnt < $iBdlCnt)? $iBdbCnt: $iBdlCnt; | |
| 1065 | $rhInfo->{_FILEH_}->read($sWk, OLE::Storage_Lite::LongIntSize()*$iGetCnt); | |
| 1066 | push @aBdList, unpack("V$iGetCnt", $sWk); | |
| 1067 | $iBdbCnt -= $iGetCnt; | |
| 1068 | $rhInfo->{_FILEH_}->read($sWk, OLE::Storage_Lite::LongIntSize()); | |
| 1069 | $iBlock = unpack("V", $sWk); | |
| 1070 | } | |
| 1071 | #3.Get BDs | |
| 1072 | my @aWk; | |
| 1073 | my %hBd; | |
| 1074 | my $iBlkNo = 0; | |
| 1075 | my $iBdL; | |
| 1076 | my $i; | |
| 1077 | my $iBdCnt = int($rhInfo->{_BIG_BLOCK_SIZE} / OLE::Storage_Lite::LongIntSize()); | |
| 1078 | foreach $iBdL (@aBdList) { | |
| 1079 | _setFilePos($iBdL, 0, $rhInfo); | |
| 1080 | $rhInfo->{_FILEH_}->read($sWk, $rhInfo->{_BIG_BLOCK_SIZE}); | |
| 1081 | @aWk = unpack("V$iBdCnt", $sWk); | |
| 1082 | for($i=0;$i<$iBdCnt;$i++, $iBlkNo++) { | |
| 1083 | if($aWk[$i] != ($iBlkNo+1)){ | |
| 1084 | $hBd{$iBlkNo} = $aWk[$i]; | |
| 1085 | } | |
| 1086 | } | |
| 1087 | } | |
| 1088 | return \%hBd; | |
| 1089 | } | |
| 1090 | #------------------------------------------------------------------------------ | |
| 1091 | # getNthPps (OLE::Storage_Lite) | |
| 1092 | #------------------------------------------------------------------------------ | |
| 1093 | sub _getNthPps($$$){ | |
| 1094 | my($iPos, $rhInfo, $bData) = @_; | |
| 1095 | my($iPpsStart) = ($rhInfo->{_ROOT_START}); | |
| 1096 | my($iPpsBlock, $iPpsPos); | |
| 1097 | my $sWk; | |
| 1098 | my $iBlock; | |
| 1099 | ||
| 1100 | my $iBaseCnt = $rhInfo->{_BIG_BLOCK_SIZE} / OLE::Storage_Lite::PpsSize(); | |
| 1101 | $iPpsBlock = int($iPos / $iBaseCnt); | |
| 1102 | $iPpsPos = $iPos % $iBaseCnt; | |
| 1103 | ||
| 1104 | $iBlock = _getNthBlockNo($iPpsStart, $iPpsBlock, $rhInfo); | |
| 1105 | return undef unless(defined($iBlock)); | |
| 1106 | ||
| 1107 | _setFilePos($iBlock, OLE::Storage_Lite::PpsSize()*$iPpsPos, $rhInfo); | |
| 1108 | $rhInfo->{_FILEH_}->read($sWk, OLE::Storage_Lite::PpsSize()); | |
| 1109 | return undef unless($sWk); | |
| 1110 | my $iNmSize = unpack("v", substr($sWk, 0x40, 2)); | |
| 1111 | $iNmSize = ($iNmSize > 2)? $iNmSize - 2 : $iNmSize; | |
| 1112 | my $sNm= substr($sWk, 0, $iNmSize); | |
| 1113 | my $iType = unpack("C", substr($sWk, 0x42, 2)); | |
| 1114 | my $lPpsPrev = unpack("V", substr($sWk, 0x44, OLE::Storage_Lite::LongIntSize())); | |
| 1115 | my $lPpsNext = unpack("V", substr($sWk, 0x48, OLE::Storage_Lite::LongIntSize())); | |
| 1116 | my $lDirPps = unpack("V", substr($sWk, 0x4C, OLE::Storage_Lite::LongIntSize())); | |
| 1117 | my @raTime1st = | |
| 1118 | (($iType == OLE::Storage_Lite::PpsType_Root()) or ($iType == OLE::Storage_Lite::PpsType_Dir()))? | |
| 1119 | OLEDate2Local(substr($sWk, 0x64, 8)) : undef , | |
| 1120 | my @raTime2nd = | |
| 1121 | (($iType == OLE::Storage_Lite::PpsType_Root()) or ($iType == OLE::Storage_Lite::PpsType_Dir()))? | |
| 1122 | OLEDate2Local(substr($sWk, 0x6C, 8)) : undef, | |
| 1123 | my($iStart, $iSize) = unpack("VV", substr($sWk, 0x74, 8)); | |
| 1124 | if($bData) { | |
| 1125 | my $sData = _getData($iType, $iStart, $iSize, $rhInfo); | |
| 1126 | return OLE::Storage_Lite::PPS->new( | |
| 1127 | $iPos, $sNm, $iType, $lPpsPrev, $lPpsNext, $lDirPps, | |
| 1128 | \@raTime1st, \@raTime2nd, $iStart, $iSize, $sData, undef); | |
| 1129 | } | |
| 1130 | else { | |
| 1131 | return OLE::Storage_Lite::PPS->new( | |
| 1132 | $iPos, $sNm, $iType, $lPpsPrev, $lPpsNext, $lDirPps, | |
| 1133 | \@raTime1st, \@raTime2nd, $iStart, $iSize, undef, undef); | |
| 1134 | } | |
| 1135 | } | |
| 1136 | #------------------------------------------------------------------------------ | |
| 1137 | # _setFilePos (OLE::Storage_Lite) | |
| 1138 | #------------------------------------------------------------------------------ | |
| 1139 | sub _setFilePos($$$){ | |
| 1140 | my($iBlock, $iPos, $rhInfo) = @_; | |
| 1141 | $rhInfo->{_FILEH_}->seek(($iBlock+1)*$rhInfo->{_BIG_BLOCK_SIZE}+$iPos, 0); | |
| 1142 | } | |
| 1143 | #------------------------------------------------------------------------------ | |
| 1144 | # _getNthBlockNo (OLE::Storage_Lite) | |
| 1145 | #------------------------------------------------------------------------------ | |
| 1146 | sub _getNthBlockNo($$$){ | |
| 1147 | my($iStBlock, $iNth, $rhInfo) = @_; | |
| 1148 | my $iSv; | |
| 1149 | my $iNext = $iStBlock; | |
| 1150 | for(my $i =0; $i<$iNth; $i++) { | |
| 1151 | $iSv = $iNext; | |
| 1152 | $iNext = _getNextBlockNo($iSv, $rhInfo); | |
| 1153 | return undef unless _isNormalBlock($iNext); | |
| 1154 | } | |
| 1155 | return $iNext; | |
| 1156 | } | |
| 1157 | #------------------------------------------------------------------------------ | |
| 1158 | # _getData (OLE::Storage_Lite) | |
| 1159 | #------------------------------------------------------------------------------ | |
| 1160 | sub _getData($$$$) | |
| 1161 | { | |
| 1162 | my($iType, $iBlock, $iSize, $rhInfo) = @_; | |
| 1163 | if ($iType == OLE::Storage_Lite::PpsType_File()) { | |
| 1164 | if($iSize < OLE::Storage_Lite::DataSizeSmall()) { | |
| 1165 | return _getSmallData($iBlock, $iSize, $rhInfo); | |
| 1166 | } | |
| 1167 | else { | |
| 1168 | return _getBigData($iBlock, $iSize, $rhInfo); | |
| 1169 | } | |
| 1170 | } | |
| 1171 | elsif($iType == OLE::Storage_Lite::PpsType_Root()) { #Root | |
| 1172 | return _getBigData($iBlock, $iSize, $rhInfo); | |
| 1173 | } | |
| 1174 | elsif($iType == OLE::Storage_Lite::PpsType_Dir()) { # Directory | |
| 1175 | return undef; | |
| 1176 | } | |
| 1177 | } | |
| 1178 | #------------------------------------------------------------------------------ | |
| 1179 | # _getBigData (OLE::Storage_Lite) | |
| 1180 | #------------------------------------------------------------------------------ | |
| 1181 | sub _getBigData($$$) | |
| 1182 | { | |
| 1183 | my($iBlock, $iSize, $rhInfo) = @_; | |
| 1184 | my($iRest, $sWk, $sRes); | |
| 1185 | ||
| 1186 | return '' unless(_isNormalBlock($iBlock)); | |
| 1187 | $iRest = $iSize; | |
| 1188 | my($i, $iGetSize, $iNext); | |
| 1189 | $sRes = ''; | |
| 1190 | my @aKeys= sort({$a<=>$b} keys(%{$rhInfo->{_BBD_INFO}})); | |
| 1191 | ||
| 1192 | while ($iRest > 0) { | |
| 1193 | my @aRes = grep($_ >= $iBlock, @aKeys); | |
| 1194 | my $iNKey = $aRes[0]; | |
| 1195 | $i = $iNKey - $iBlock; | |
| 1196 | $iNext = $rhInfo->{_BBD_INFO}{$iNKey}; | |
| 1197 | _setFilePos($iBlock, 0, $rhInfo); | |
| 1198 | my $iGetSize = ($rhInfo->{_BIG_BLOCK_SIZE} * ($i+1)); | |
| 1199 | $iGetSize = $iRest if($iRest < $iGetSize); | |
| 1200 | $rhInfo->{_FILEH_}->read( $sWk, $iGetSize); | |
| 1201 | $sRes .= $sWk; | |
| 1202 | $iRest -= $iGetSize; | |
| 1203 | $iBlock= $iNext; | |
| 1204 | } | |
| 1205 | return $sRes; | |
| 1206 | } | |
| 1207 | #------------------------------------------------------------------------------ | |
| 1208 | # _getNextBlockNo (OLE::Storage_Lite) | |
| 1209 | #------------------------------------------------------------------------------ | |
| 1210 | sub _getNextBlockNo($$){ | |
| 1211 | my($iBlockNo, $rhInfo) = @_; | |
| 1212 | my $iRes = $rhInfo->{_BBD_INFO}->{$iBlockNo}; | |
| 1213 | return defined($iRes)? $iRes: $iBlockNo+1; | |
| 1214 | } | |
| 1215 | #------------------------------------------------------------------------------ | |
| 1216 | # _isNormalBlock (OLE::Storage_Lite) | |
| 1217 | # 0xFFFFFFFC : BDList, 0xFFFFFFFD : BBD, | |
| 1218 | # 0xFFFFFFFE: End of Chain 0xFFFFFFFF : unused | |
| 1219 | #------------------------------------------------------------------------------ | |
| 1220 | sub _isNormalBlock($){ | |
| 1221 | my($iBlock) = @_; | |
| 1222 | return ($iBlock < 0xFFFFFFFC)? 1: undef; | |
| 1223 | } | |
| 1224 | #------------------------------------------------------------------------------ | |
| 1225 | # _getSmallData (OLE::Storage_Lite) | |
| 1226 | #------------------------------------------------------------------------------ | |
| 1227 | sub _getSmallData($$$) | |
| 1228 | { | |
| 1229 | my($iSmBlock, $iSize, $rhInfo) = @_; | |
| 1230 | my($sRes, $sWk); | |
| 1231 | my $iRest = $iSize; | |
| 1232 | $sRes = ''; | |
| 1233 | while ($iRest > 0) { | |
| 1234 | _setFilePosSmall($iSmBlock, $rhInfo); | |
| 1235 | $rhInfo->{_FILEH_}->read($sWk, | |
| 1236 | ($iRest >= $rhInfo->{_SMALL_BLOCK_SIZE})? | |
| 1237 | $rhInfo->{_SMALL_BLOCK_SIZE}: $iRest); | |
| 1238 | $sRes .= $sWk; | |
| 1239 | $iRest -= $rhInfo->{_SMALL_BLOCK_SIZE}; | |
| 1240 | $iSmBlock= _getNextSmallBlockNo($iSmBlock, $rhInfo); | |
| 1241 | } | |
| 1242 | return $sRes; | |
| 1243 | } | |
| 1244 | #------------------------------------------------------------------------------ | |
| 1245 | # _setFilePosSmall(OLE::Storage_Lite) | |
| 1246 | #------------------------------------------------------------------------------ | |
| 1247 | sub _setFilePosSmall($$) | |
| 1248 | { | |
| 1249 | my($iSmBlock, $rhInfo) = @_; | |
| 1250 | my $iSmStart = $rhInfo->{_SB_START}; | |
| 1251 | my $iBaseCnt = $rhInfo->{_BIG_BLOCK_SIZE} / $rhInfo->{_SMALL_BLOCK_SIZE}; | |
| 1252 | my $iNth = int($iSmBlock/$iBaseCnt); | |
| 1253 | my $iPos = $iSmBlock % $iBaseCnt; | |
| 1254 | ||
| 1255 | my $iBlk = _getNthBlockNo($iSmStart, $iNth, $rhInfo); | |
| 1256 | _setFilePos($iBlk, $iPos * $rhInfo->{_SMALL_BLOCK_SIZE}, $rhInfo); | |
| 1257 | } | |
| 1258 | #------------------------------------------------------------------------------ | |
| 1259 | # _getNextSmallBlockNo (OLE::Storage_Lite) | |
| 1260 | #------------------------------------------------------------------------------ | |
| 1261 | sub _getNextSmallBlockNo($$) | |
| 1262 | { | |
| 1263 | my($iSmBlock, $rhInfo) = @_; | |
| 1264 | my($sWk); | |
| 1265 | ||
| 1266 | my $iBaseCnt = $rhInfo->{_BIG_BLOCK_SIZE} / OLE::Storage_Lite::LongIntSize(); | |
| 1267 | my $iNth = int($iSmBlock/$iBaseCnt); | |
| 1268 | my $iPos = $iSmBlock % $iBaseCnt; | |
| 1269 | my $iBlk = _getNthBlockNo($rhInfo->{_SBD_START}, $iNth, $rhInfo); | |
| 1270 | _setFilePos($iBlk, $iPos * OLE::Storage_Lite::LongIntSize(), $rhInfo); | |
| 1271 | $rhInfo->{_FILEH_}->read($sWk, OLE::Storage_Lite::LongIntSize()); | |
| 1272 | return unpack("V", $sWk); | |
| 1273 | ||
| 1274 | } | |
| 1275 | #------------------------------------------------------------------------------ | |
| 1276 | # Asc2Ucs: OLE::Storage_Lite | |
| 1277 | #------------------------------------------------------------------------------ | |
| 1278 | sub Asc2Ucs($) | |
| 1279 | { | |
| 1280 | my($sAsc) = @_; | |
| 1281 | return join("\x00", split //, $sAsc) . "\x00"; | |
| 1282 | } | |
| 1283 | #------------------------------------------------------------------------------ | |
| 1284 | # Ucs2Asc: OLE::Storage_Lite | |
| 1285 | #------------------------------------------------------------------------------ | |
| 1286 | sub Ucs2Asc($) | |
| 1287 | { | |
| 1288 | my($sUcs) = @_; | |
| 1289 | return join('', map(pack('c', $_), unpack('v*', $sUcs))); | |
| 1290 | } | |
| 1291 | #------------------------------------------------------------------------------ | |
| 1292 | # OLE Date->Localtime | |
| 1293 | #------------------------------------------------------------------------------ | |
| 1294 | sub OLEDate2Local($) | |
| 1295 | { | |
| 1296 | my($sDateTime) = @_; | |
| 1297 | my($iSec, $iMin, $iHour, $iDay, $iMon, $iYear); | |
| 1298 | my($iDate); | |
| 1299 | my($iDt, $iYDays); | |
| 1300 | #1.Divide Day and Time | |
| 1301 | my $iBigDt = Math::BigInt->new(0); | |
| 1302 | foreach my $sWk (reverse(split //, $sDateTime)) { | |
| 1303 | $iBigDt *= 0x100; | |
| 1304 | $iBigDt += ord($sWk); | |
| 1305 | } | |
| 1306 | my $iHSec = $iBigDt % 10000000; | |
| 1307 | $iBigDt /= 10000000; | |
| 1308 | my $iBigDay = int($iBigDt / (24*3600)) + 1; | |
| 1309 | my $iTime = int($iBigDt % (24*3600)); | |
| 1310 | #2. Year->Day(1601/1/2?) | |
| 1311 | $iDt = $iBigDay; | |
| 1312 | $iYear = 1601; | |
| 1313 | $iYDays = _yearDays($iYear); #Not 365 (365 days is Only in Excel World) | |
| 1314 | while($iDt > $iYDays) { | |
| 1315 | $iDt -= $iYDays; | |
| 1316 | $iYear++; | |
| 1317 | $iYDays = _yearDays($iYear); | |
| 1318 | } | |
| 1319 | my $iMD; | |
| 1320 | for($iMon=1;$iMon < 12; $iMon++){ | |
| 1321 | $iMD = _monthDays($iMon, $iYear); | |
| 1322 | last if($iDt <= $iMD); | |
| 1323 | $iDt -= $iMD; | |
| 1324 | } | |
| 1325 | $iDay = $iDt; | |
| 1326 | #3. Hour->iSec | |
| 1327 | $iHour = int($iTime / 3600); | |
| 1328 | $iMin = int(($iTime % 3600) / 60); | |
| 1329 | $iSec = $iTime % 60; | |
| 1330 | return ($iSec, $iMin, $iHour, $iDay, $iMon - 1, $iYear-1900, $iHSec); | |
| 1331 | } | |
| 1332 | #------------------------------------------------------------------------------ | |
| 1333 | # Localtime->OLE Date | |
| 1334 | #------------------------------------------------------------------------------ | |
| 1335 | sub LocalDate2OLE($) | |
| 1336 | { | |
| 1337 | my($raDate) = @_; | |
| 1338 | return "\x00" x 8 unless($raDate); | |
| 1339 | ||
| 1340 | my ($iSec, $iMin, $iHour, $iDay, $iMon, $iYear, $iHSec) = @{$raDate}; | |
| 1341 | $iSec ||=0; $iMin ||=0; $iHour ||=0; $iDay ||=0; $iMon ||=0; $iYear ||=0; $iHSec ||=0; | |
| 1342 | ||
| 1343 | my($iDate); | |
| 1344 | my($iDt, $iYDays); | |
| 1345 | #1. Year -> Days | |
| 1346 | $iDate = -1; | |
| 1347 | for(my $iY=1601;$iY<($iYear+1900);$iY++){ | |
| 1348 | $iDate += _yearDays($iY); | |
| 1349 | } | |
| 1350 | ||
| 1351 | for(my $iM=0;$iM < $iMon ; $iM++){ | |
| 1352 | $iDate += _monthDays($iM+1, ($iYear+1900)); | |
| 1353 | } | |
| 1354 | $iDate += $iDay; | |
| 1355 | #2. Hours->Sec + HighReso | |
| 1356 | my $iBigDt = Math::BigInt->new(0); | |
| 1357 | $iBigDt += $iHour*3600 + $iMin*60+ $iSec; | |
| 1358 | $iBigDt += ($iDate*(24*3600)); | |
| 1359 | $iBigDt *= 10000000; | |
| 1360 | $iBigDt += $iHSec if($iHSec); | |
| 1361 | #3. Make HEX string | |
| 1362 | my $iHex; | |
| 1363 | my $sRes = ''; | |
| 1364 | for(my $i=0;$i<8;$i++) { | |
| 1365 | $iHex = $iBigDt % 0x100; | |
| 1366 | $sRes .= pack 'c', $iHex; | |
| 1367 | $iBigDt /= 0x100; | |
| 1368 | } | |
| 1369 | return $sRes; | |
| 1370 | } | |
| 1371 | #------------------------------------------------------------------------------ | |
| 1372 | # _leapYear (OLE::Storage_Lite) | |
| 1373 | #------------------------------------------------------------------------------ | |
| 1374 | sub _leapYear($) { | |
| 1375 | my($iYear)=@_; | |
| 1376 | return undef unless($iYear); | |
| 1377 | return ((($iYear % 4)==0) && (($iYear % 100) || ($iYear % 400)==0))? 1: 0; | |
| 1378 | } | |
| 1379 | #------------------------------------------------------------------------------ | |
| 1380 | # _yearDays (OLE::Storage_Lite) | |
| 1381 | #------------------------------------------------------------------------------ | |
| 1382 | sub _yearDays($) { | |
| 1383 | my($iYear)=@_; | |
| 1384 | return _leapYear($iYear)? 366: 365; | |
| 1385 | } | |
| 1386 | #------------------------------------------------------------------------------ | |
| 1387 | # _monthDays (OLE::Storage_Lite) | |
| 1388 | #------------------------------------------------------------------------------ | |
| 1389 | sub _monthDays($$) { | |
| 1390 | my($iMon, $iYear)=@_; | |
| 1391 | if($iMon == 1 || $iMon == 3 || $iMon == 5 || $iMon == 7 || $iMon == 8 | |
| 1392 | || $iMon == 10 || $iMon == 12) { | |
| 1393 | return 31; | |
| 1394 | } | |
| 1395 | elsif($iMon == 4 || $iMon == 6 || $iMon == 9 || $iMon == 11) { | |
| 1396 | return 30; | |
| 1397 | } | |
| 1398 | elsif($iMon == 2) { | |
| 1399 | return _leapYear($iYear)? 29: 28; | |
| 1400 | } | |
| 1401 | } | |
| 1402 | 1; | |
| 1403 | __END__ | |
| 1404 | ||
| 1405 | ||
| 1406 | =head1 NAME | |
| 1407 | ||
| 1408 | OLE::Storage_Lite - Simple Class for OLE document interface. (Version: 0.11) | |
| 1409 | ||
| 1410 | =head1 SYNOPSIS | |
| 1411 | ||
| 1412 | use OLE::Storage_Lite; | |
| 1413 | use strict; | |
| 1414 | #1. Initialize | |
| 1415 | #1.1 From File | |
| 1416 | my $oOl = OLE::Storage_Lite->new("some.xls"); | |
| 1417 | #1.2 From Scalar | |
| 1418 | my $oOl = OLE::Storage_Lite->new(\$sBuff); | |
| 1419 | #1.3 From IO::Handle object | |
| 1420 | use IO::File; | |
| 1421 | my $oIo = new IO::File; | |
| 1422 | $oIo->open("<iofile.xls"); | |
| 1423 | binmode($oIo); | |
| 1424 | my $oOl = OLE::Storage_Lite->new($oFile); | |
| 1425 | #2. Read and Get Data | |
| 1426 | my $oPps = $oOl->getPpsTree(1); | |
| 1427 | #3.Save Data | |
| 1428 | #3.1 As File | |
| 1429 | $oPps->save("kaba.xls"); #kaba.xls | |
| 1430 | $oPps->save('-'); #STDOUT | |
| 1431 | #3.2 As Scalar | |
| 1432 | $oPps->save(\$sBuff); | |
| 1433 | #3.3 As IO::Handle object | |
| 1434 | my $oIo = new IO::File; | |
| 1435 | $oIo->open(">iofile.xls"); | |
| 1436 | bimode($oIo); | |
| 1437 | $oPps->save($oIo); | |
| 1438 | ||
| 1439 | =head1 DESCRIPTION | |
| 1440 | ||
| 1441 | OLE::Storage_Lite allows you to read and write an OLE structured file. | |
| 1442 | Please refer OLE::Storage by Martin Schwartz. | |
| 1443 | ||
| 1444 | OLE::Storage_Lite::PPS is a class representing PPS. | |
| 1445 | OLE::Storage_Lite::PPS::Root, OLE::Storage_Lite::PPS::File and OLE::Storage_Lite::PPS::Dir | |
| 1446 | are subclasses of OLE::Storage_Lite::PPS. | |
| 1447 | ||
| 1448 | ||
| 1449 | =head2 new | |
| 1450 | ||
| 1451 | I<$oOle> = OLE::Storage_Lite->new(I<$sFile>); | |
| 1452 | ||
| 1453 | Constructor. | |
| 1454 | Creates a OLE::Storage_Lite object for I<$sFile>. | |
| 1455 | I<$sFile> must be a correct file name. | |
| 1456 | ||
| 1457 | From 0.06, I<$sFile> may be a scalar reference of file contents (ex. \$sBuff) | |
| 1458 | and IO::Handle object (including IO::File etc). | |
| 1459 | ||
| 1460 | =head2 getPpsTree | |
| 1461 | ||
| 1462 | I<$oPpsRoot> = I<oOle>->getPpsTree([$bData]); | |
| 1463 | ||
| 1464 | returns PPS as OLE::Storage_Lite::PPS::Root object. | |
| 1465 | Other PPS objects will be included as its children. | |
| 1466 | if I<$bData> is true, the objects will have data in the file. | |
| 1467 | ||
| 1468 | =head2 getPpsSearch | |
| 1469 | ||
| 1470 | I<$oPpsRoot> = I<oOle>->getPpsTree($raName [, $bData][, $iCase] ); | |
| 1471 | ||
| 1472 | returns PPSs as OLE::Storage_Lite::PPS objects that has the name specified in | |
| 1473 | I<$raName> array. | |
| 1474 | if I<$bData> is true, the objects will have data in the file. | |
| 1475 | if I<$iCase> is true, search with case insensitive. | |
| 1476 | ||
| 1477 | =head2 getNthPps | |
| 1478 | ||
| 1479 | I<$oPpsRoot> = I<oOle>->getNthPps($iNth [, $bData]); | |
| 1480 | ||
| 1481 | returns PPS as OLE::Storage_Lite::PPS object specified number(I<$iNth>). | |
| 1482 | if I<$bData> is true, the objects will have data in the file. | |
| 1483 | ||
| 1484 | =head2 Asc2Ucs | |
| 1485 | ||
| 1486 | I<$sUcs2> = OLE::Storage_Lite::Asc2Ucs(I<$sAsc>); | |
| 1487 | ||
| 1488 | Utility function. | |
| 1489 | Just adding 0x00 afeter every characters in I<$sAsc>. | |
| 1490 | ||
| 1491 | =head2 Ucs2Asc | |
| 1492 | ||
| 1493 | I<$sAsc> = OLE::Storage_Lite::Ucs2Asc(I<$sUcs2>); | |
| 1494 | ||
| 1495 | Utility function. | |
| 1496 | Just deletes 0x00 afeter words in I<$sUcs>. | |
| 1497 | ||
| 1498 | =head1 OLE::Storage_Lite::PPS | |
| 1499 | ||
| 1500 | OLE::Storage_Lite::PPS has these properties: | |
| 1501 | ||
| 1502 | =over 4 | |
| 1503 | ||
| 1504 | =item No | |
| 1505 | ||
| 1506 | order number in saving. | |
| 1507 | ||
| 1508 | =item Name | |
| 1509 | ||
| 1510 | its name in UCS2 (a.k.a Unicode). | |
| 1511 | ||
| 1512 | =item Type | |
| 1513 | ||
| 1514 | its type (1:Dir, 2:File (Data), 5: Root) | |
| 1515 | ||
| 1516 | =item PrevPps | |
| 1517 | ||
| 1518 | previous pps (as No) | |
| 1519 | ||
| 1520 | =item NextPps | |
| 1521 | ||
| 1522 | next pps (as No) | |
| 1523 | ||
| 1524 | =item DirPps | |
| 1525 | ||
| 1526 | dir pps (as No). | |
| 1527 | ||
| 1528 | =item Time1st | |
| 1529 | ||
| 1530 | timestamp1st in array ref as similar fomat of localtime. | |
| 1531 | ||
| 1532 | =item Time2nd | |
| 1533 | ||
| 1534 | timestamp2nd in array ref as similar fomat of localtime. | |
| 1535 | ||
| 1536 | =item StartBlock | |
| 1537 | ||
| 1538 | start block number | |
| 1539 | ||
| 1540 | =item Size | |
| 1541 | ||
| 1542 | size of the pps | |
| 1543 | ||
| 1544 | =item Data | |
| 1545 | ||
| 1546 | its data | |
| 1547 | ||
| 1548 | =item Child | |
| 1549 | ||
| 1550 | its child PPSs in array ref | |
| 1551 | ||
| 1552 | =back | |
| 1553 | ||
| 1554 | =head1 OLE::Storage_Lite::PPS::Root | |
| 1555 | ||
| 1556 | OLE::Storage_Lite::PPS::Root has 2 methods. | |
| 1557 | ||
| 1558 | =head2 new | |
| 1559 | ||
| 1560 | I<$oRoot> = OLE::Storage_Lite::PPS::Root->new( | |
| 1561 | I<$raTime1st>, | |
| 1562 | I<$raTime2nd>, | |
| 1563 | I<$raChild>); | |
| 1564 | ||
| 1565 | Constructor. | |
| 1566 | ||
| 1567 | I<$raTime1st>, I<$raTime2nd> is a array ref as | |
| 1568 | ($iSec, $iMin, $iHour, $iDay, $iMon, $iYear, $iHSec). | |
| 1569 | $iSec means seconds, $iMin means minutes. $iHour means hours. | |
| 1570 | $iDay means day. $iMon is month -1. $iYear is year - 1900. | |
| 1571 | $iHSec is seconds/10,000,000 in Math::BigInt. | |
| 1572 | ||
| 1573 | I<$raChild> is a array ref of children PPSs. | |
| 1574 | ||
| 1575 | =head2 save | |
| 1576 | ||
| 1577 | I<$oRoot> = $o<oRoot>->save( | |
| 1578 | I<$sFile>, | |
| 1579 | I<$bNoAs>); | |
| 1580 | ||
| 1581 | Saves infomations into I<$sFile>. I<$sFile> is '-', this will use STDOUT. | |
| 1582 | ||
| 1583 | From 0.06, I<$sFile> may be a scalar reference of file contents (ex. \$sBuff) | |
| 1584 | and IO::Handle object (including IO::File etc). | |
| 1585 | ||
| 1586 | if I<$bNoAs> is defined, this function will use the No of PPSs for saving order. | |
| 1587 | if I<$bNoAs> is undefined, this will calculate PPS saving order. | |
| 1588 | ||
| 1589 | =head1 OLE::Storage_Lite::PPS::Dir | |
| 1590 | ||
| 1591 | OLE::Storage_Lite::PPS::Dir has 1 method. | |
| 1592 | ||
| 1593 | =head2 new | |
| 1594 | ||
| 1595 | I<$oRoot> = OLE::Storage_Lite::PPS::Dir->new( | |
| 1596 | I<$sName> | |
| 1597 | [, I<$raTime1st>] | |
| 1598 | [, I<$raTime2nd>] | |
| 1599 | [, I<$raChild>]); | |
| 1600 | ||
| 1601 | Constructor. | |
| 1602 | ||
| 1603 | I<$sName> is a name of the PPS. | |
| 1604 | ||
| 1605 | I<$raTime1st>, I<$raTime2nd> is a array ref as | |
| 1606 | ($iSec, $iMin, $iHour, $iDay, $iMon, $iYear, $iHSec). | |
| 1607 | $iSec means seconds, $iMin means minutes. $iHour means hours. | |
| 1608 | $iDay means day. $iMon is month -1. $iYear is year - 1900. | |
| 1609 | $iHSec is seconds/10,000,000 in Math::BigInt. | |
| 1610 | ||
| 1611 | I<$raChild> is a array ref of children PPSs. | |
| 1612 | ||
| 1613 | ||
| 1614 | =head1 OLE::Storage_Lite::PPS::File | |
| 1615 | ||
| 1616 | OLE::Storage_Lite::PPS::File has 3 method. | |
| 1617 | ||
| 1618 | =head2 new | |
| 1619 | ||
| 1620 | I<$oRoot> = OLE::Storage_Lite::PPS::File->new(I<$sName>, I<$sData>); | |
| 1621 | ||
| 1622 | I<$sName> is name of the PPS. | |
| 1623 | ||
| 1624 | I<$sData> is data of the PPS. | |
| 1625 | ||
| 1626 | =head2 newFile | |
| 1627 | ||
| 1628 | I<$oRoot> = OLE::Storage_Lite::PPS::File->newFile(I<$sName>, I<$sFile>); | |
| 1629 | ||
| 1630 | This function makes to use file handle for geting and storing data. | |
| 1631 | ||
| 1632 | I<$sName> is name of the PPS. | |
| 1633 | ||
| 1634 | If I<$sFile> is scalar, it assumes that is a filename. | |
| 1635 | If I<$sFile> is an IO::Handle object, it uses that specified handle. | |
| 1636 | If I<$sFile> is undef or '', it uses temporary file. | |
| 1637 | ||
| 1638 | CAUTION: Take care I<$sFile> will be updated by I<append> method. | |
| 1639 | So if you want to use IO::Handle and append a data to it, | |
| 1640 | you should open the handle with "r+". | |
| 1641 | ||
| 1642 | =head2 append | |
| 1643 | ||
| 1644 | I<$oRoot> = $oPps->append($sData); | |
| 1645 | ||
| 1646 | appends specified data to that PPS. | |
| 1647 | ||
| 1648 | I<$sData> is appending data for that PPS. | |
| 1649 | ||
| 1650 | =head1 CAUTION | |
| 1651 | ||
| 1652 | A saved file with VBA (a.k.a Macros) by this module will not work correctly. | |
| 1653 | However modules can get the same information from the file, | |
| 1654 | the file occurs a error in application(Word, Excel ...). | |
| 1655 | ||
| 1656 | =head1 COPYRIGHT | |
| 1657 | ||
| 1658 | The OLE::Storage_Lite module is Copyright (c) 2000,2001 Kawai Takanori. Japan. | |
| 1659 | All rights reserved. | |
| 1660 | ||
| 1661 | You may distribute under the terms of either the GNU General Public | |
| 1662 | License or the Artistic License, as specified in the Perl README file. | |
| 1663 | ||
| 1664 | =head1 ACKNOWLEDGEMENTS | |
| 1665 | ||
| 1666 | First of all, I would like to acknowledge to Martin Schwartz and his module OLE::Storage. | |
| 1667 | ||
| 1668 | =head1 AUTHOR | |
| 1669 | ||
| 1670 | Kawai Takanori kwitknr@cpan.org | |
| 1671 | ||
| 1672 | =head1 SEE ALSO | |
| 1673 | ||
| 1674 | OLE::Storage | |
| 1675 | ||
| 1676 | =cut |
| 0 | # Spreadsheet::ParseExcel::Dump | |
| 1 | # by Kawai, Takanori (Hippo2000) 2001.2.2 | |
| 2 | # This Program is ALPHA version. | |
| 3 | #============================================================================== | |
| 4 | # Spreadsheet::ParseExcel::Dump | |
| 5 | #============================================================================== | |
| 6 | package Spreadsheet::ParseExcel::Dump; | |
| 7 | require Exporter; | |
| 8 | use strict; | |
| 9 | use vars qw($VERSION @ISA); | |
| 10 | @ISA = qw(Exporter); | |
| 11 | $VERSION=0.01; | |
| 12 | sub subDUMP($$$$); | |
| 13 | sub OpName($); | |
| 14 | my %NameTbl = ( | |
| 15 | #P291 | |
| 16 | 0x0A =>'EOF', 0x0C =>'CALCCOUNT', | |
| 17 | 0x0D =>'CALCMODE', 0x0E =>'PRECISION', | |
| 18 | 0x0F =>'REFMODE', 0x10 =>'DELTA', | |
| 19 | 0x11 =>'ITERATION', 0x12 =>'PROTECT', | |
| 20 | 0x13 =>'PASSWORD', 0x14 =>'HEADER', | |
| 21 | ||
| 22 | 0x15 =>'FOOTER', 0x16 =>'EXTERNCOUNT', | |
| 23 | 0x17 =>'EXTERNSHEET', 0x19 =>'WINDOWPROTECT', | |
| 24 | 0x1A =>'VERTICALPAGEBREAKS', 0x1B =>'HORIZONTALPAGEBREAKS', | |
| 25 | 0x1C =>'NOTE', 0x1D =>'SELECTION', | |
| 26 | 0x22 =>'1904', 0x26 =>'LEFTMARGIN', | |
| 27 | ||
| 28 | 0x27 =>'RIGHTMARGIN', 0x28 =>'TOPMARGIN', | |
| 29 | 0x29 =>'BOTTOMMARGIN', 0x2A =>'PRINTHEADERS', | |
| 30 | 0x2B =>'PRINTGRIDLINES', 0x2F =>'FILEPASS', | |
| 31 | 0x3C =>'COUNTINUE', 0x3D =>'WINDOW1', | |
| 32 | 0x40 =>'BACKUP', 0x41 =>'PANE', | |
| 33 | ||
| 34 | 0x42 =>'CODEPAGE', 0x4D =>'PLS', | |
| 35 | 0x50 =>'DCON', 0x51 =>'DCONREF', | |
| 36 | #P292 | |
| 37 | 0x52 =>'DCONNAME', 0x55 =>'DEFCOLWIDTH', | |
| 38 | 0x59 =>'XCT', 0x5A =>'CRN', | |
| 39 | 0x5B =>'FILESHARING', 0x5C =>'WRITEACCES', | |
| 40 | 0x5D =>'OBJ', 0x5E =>'UNCALCED', | |
| 41 | 0x5F =>'SAVERECALC', 0x60 =>'TEMPLATE', | |
| 42 | ||
| 43 | 0x63 =>'OBJPROTECT', 0x7D =>'COLINFO', | |
| 44 | 0x7E =>'RK', 0x7F =>'IMDATA', | |
| 45 | 0x80 =>'GUTS', 0x81 =>'WSBOOL', | |
| 46 | 0x82 =>'GRIDSET', 0x83 =>'HCENTER', | |
| 47 | 0x84 =>'VCENTER', 0x85 =>'BOUNDSHEET', | |
| 48 | ||
| 49 | 0x86 =>'WRITEPROT', 0x87 =>'ADDIN', | |
| 50 | 0x88 =>'EDG', 0x89 =>'PUB', | |
| 51 | 0x8C =>'COUNTRY', 0x8D =>'HIDEOBJ', | |
| 52 | 0x90 =>'SORT', 0x91 =>'SUB', | |
| 53 | 0x92 =>'PALETTE', 0x94 =>'LHRECORD', | |
| 54 | ||
| 55 | 0x95 =>'LHNGRAPH', 0x96 =>'SOUND', | |
| 56 | 0x98 =>'LPR', 0x99 =>'STANDARDWIDTH', | |
| 57 | 0x9A =>'FNGROUPNAME', 0x9B =>'FILTERMODE', | |
| 58 | 0x9C =>'FNGROUPCOUNT', | |
| 59 | #P293 | |
| 60 | 0x9D =>'AUTOFILTERINFO', 0x9E =>'AUTOFILTER', | |
| 61 | 0xA0 =>'SCL', 0xA1 =>'SETUP', | |
| 62 | 0xA9 =>'COORDLIST', 0xAB =>'GCW', | |
| 63 | 0xAE =>'SCENMAN', 0xAF =>'SCENARIO', | |
| 64 | 0xB0 =>'SXVIEW', 0xB1 =>'SXVD', | |
| 65 | ||
| 66 | 0xB2 =>'SXV', 0xB4 =>'SXIVD', | |
| 67 | 0xB5 =>'SXLI', 0xB6 =>'SXPI', | |
| 68 | 0xB8 =>'DOCROUTE', 0xB9 =>'RECIPNAME', | |
| 69 | 0xBC =>'SHRFMLA', 0xBD =>'MULRK', | |
| 70 | 0xBE =>'MULBLANK', 0xBF =>'TOOLBARHDR', | |
| 71 | 0xC0 =>'TOOLBAREND', 0xC1 =>'MMS', | |
| 72 | ||
| 73 | 0xC2 =>'ADDMENU', 0xC3 =>'DELMENU', | |
| 74 | 0xC5 =>'SXDI', 0xC6 =>'SXDB', | |
| 75 | 0xCD =>'SXSTRING', 0xD0 =>'SXTBL', | |
| 76 | 0xD1 =>'SXTBRGIITM', 0xD2 =>'SXTBPG', | |
| 77 | 0xD3 =>'OBPROJ', 0xD5 =>'SXISDTM', | |
| 78 | ||
| 79 | 0xD6 =>'RSTRING', 0xD7 =>'DBCELL', | |
| 80 | 0xDA =>'BOOKBOOL', 0xDC =>'PARAMQRY', | |
| 81 | 0xDC =>'SXEXT', 0xDD =>'SCENPROTECT', | |
| 82 | 0xDE =>'OLESIZE', | |
| 83 | #P294 | |
| 84 | 0xDF =>'UDDESC', 0xE0 =>'XF', | |
| 85 | 0xE1 =>'INTERFACEHDR', 0xE2 =>'INTERFACEEND', | |
| 86 | 0xE3 =>'SXVS', 0xEA =>'TABIDCONF', | |
| 87 | 0xEB =>'MSODRAWINGGROUP', 0xEC =>'MSODRAWING', | |
| 88 | 0xED =>'MSODRAWINGSELECTION', 0xEF =>'PHONETICINFO', | |
| 89 | 0xF0 =>'SXRULE', | |
| 90 | ||
| 91 | 0xF1 =>'SXEXT', 0xF2 =>'SXFILT', | |
| 92 | 0xF6 =>'SXNAME', 0xF7 =>'SXSELECT', | |
| 93 | 0xF8 =>'SXPAIR', 0xF9 =>'SXFMLA', | |
| 94 | 0xFB =>'SXFORMAT', 0xFC =>'SST', | |
| 95 | 0xFD =>'LABELSST', 0xFF =>'EXTSST', | |
| 96 | ||
| 97 | 0x100 =>'SXVDEX', 0x103 =>'SXFORMULA', | |
| 98 | 0x122 =>'SXDBEX', 0x13D =>'TABID', | |
| 99 | 0x160 =>'USESELFS', 0x161 =>'DSF', | |
| 100 | 0x162 =>'XL5MODIFY', 0x1A5 =>'FILESHARING2', | |
| 101 | 0x1A9 =>'USERBVIEW', 0x1AA =>'USERVIEWBEGIN', | |
| 102 | ||
| 103 | 0x1AB =>'USERSVIEWEND', 0x1AD =>'QSI', | |
| 104 | 0x1AE =>'SUPBOOK', 0x1AF =>'PROT4REV', | |
| 105 | 0x1B0 =>'CONDFMT', 0x1B1 =>'CF', | |
| 106 | 0x1B2 =>'DVAL', | |
| 107 | #P295 | |
| 108 | 0x1B5 =>'DCONBIN', 0x1B6 =>'TXO', | |
| 109 | 0x1B7 =>'REFRESHALL', 0x1B8 =>'HLINK', | |
| 110 | 0x1BA =>'CODENAME', 0x1BB =>'SXFDBTYPE', | |
| 111 | 0x1BC =>'PROT4REVPASS', 0x1BE =>'DV', | |
| 112 | 0x200 =>'DIMENSIONS', 0x201 =>'BLANK', | |
| 113 | ||
| 114 | 0x202 =>'Integer', #Not Documented | |
| 115 | 0x203 =>'NUMBER', 0x204 =>'LABEL', | |
| 116 | 0x205 =>'BOOLERR', 0x207 =>'STRING', | |
| 117 | 0x208 =>'ROW', 0x20B =>'INDEX', | |
| 118 | 0x218 =>'NAME', 0x221 =>'ARRAY', | |
| 119 | 0x223 =>'EXTERNNAME', 0x225 =>'DEFAULTROWHEIGHT', | |
| 120 | ||
| 121 | 0x231 =>'FONT', 0x236 =>'TABLE', | |
| 122 | 0x23E =>'WINDOW2', 0x293 =>'STYLE', | |
| 123 | 0x406 =>'FORMULA', 0x41E =>'FORMAT', | |
| 124 | ||
| 125 | 0x18 =>'NAME', | |
| 126 | ||
| 127 | 0x06 => 'FORMULA', | |
| 128 | ||
| 129 | 0x09 => 'BOF(BIFF2)', 0x209 =>'BOF(BIFF3)', | |
| 130 | 0x409 => 'BOF(BIFF4)', 0x809 =>'BOF(BIFF5-7)', | |
| 131 | ||
| 132 | 0x31 =>'FONT', 0x27E =>'RK', | |
| 133 | ||
| 134 | #Chart/Graph | |
| 135 | 0x1001 => 'UNITS', 0x1002 => 'CHART', | |
| 136 | 0x1003 => 'SERISES', 0x1006 => 'DATAFORMAT', | |
| 137 | 0x1007 => 'LINEFORMAT', 0x1009 => 'MAKERFORMAT', | |
| 138 | 0x100A => 'AREAFORMAT', 0x100B => 'PIEFORMAT', | |
| 139 | 0x100C => 'ATTACHEDLABEL', 0x100D => 'SERIESTEXT', | |
| 140 | 0x1014 => 'CHARTFORMAT', 0x1015 => 'LEGEND', | |
| 141 | 0x1016 => 'SERIESLIST', 0x1017 => 'BAR', | |
| 142 | 0x1018 => 'LINE', 0x1019 => 'PIE', | |
| 143 | 0x101A => 'AREA', 0x101B => 'SCATTER', | |
| 144 | 0x101C => 'CHARTLINE', 0x101D => 'AXIS', | |
| 145 | 0x101E => 'TICK', 0x101F => 'VALUERANGE', | |
| 146 | 0x1020 => 'CATSERRANGE', 0x1021 => 'AXISLINEFORMAT', | |
| 147 | 0x1022 => 'CHARTFORMATLINK', 0x1024 => 'DEFAULTTEXT', | |
| 148 | 0x1025 => 'TEXT', 0x1026 => 'FONTX', | |
| 149 | 0x1027 => 'OBJECTLINK', 0x1032 => 'FRAME', | |
| 150 | 0x1033 => 'BEGIN', 0x1034 => 'END', | |
| 151 | 0x1035 => 'PLOTAREA', 0x103A => '3D', | |
| 152 | 0x103C => 'PICF', 0x103D => 'DROPBAR', | |
| 153 | 0x103E => 'RADAR', 0x103F => 'SURFACE', | |
| 154 | 0x1040 => 'RADARAREA', 0x1041 => 'AXISPARENT', | |
| 155 | 0x1043 => 'LEGENDXN', 0x1044 => 'SHTPROPS', | |
| 156 | 0x1045 => 'SERTOCRT', 0x1046 => 'AXESUSED', | |
| 157 | 0x1048 => 'SBASEREF', 0x104A => 'SERPARENT', | |
| 158 | 0x104B => 'SERAUXTREND', 0x104E => 'IFMT', | |
| 159 | 0x104F => 'POS', 0x1050 => 'ALRUNS', | |
| 160 | 0x1051 => 'AI', 0x105B => 'SERAUXERRBAR', | |
| 161 | 0x105D => 'SERFMT', 0x1060 => 'FBI', | |
| 162 | 0x1061 => 'BOPPOP', 0x1062 => 'AXCEXT', | |
| 163 | 0x1063 => 'DAT', 0x1064 => 'PLOTGROWTH', | |
| 164 | 0x1065 => 'SINDEX', 0x1066 => 'GELFRAME', | |
| 165 | 0x1067 => 'BPOPPOPCUSTOM', | |
| 166 | ); | |
| 167 | #------------------------------------------------------------------------------ | |
| 168 | # subDUMP (for Spreadsheet::ParseExcel) | |
| 169 | #------------------------------------------------------------------------------ | |
| 170 | sub subDUMP($$$$) | |
| 171 | { | |
| 172 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 173 | printf "%04X:%-23s (Len:%3d) : %s\n", | |
| 174 | $bOp, OpName($bOp), $bLen, unpack("H40",$sWk); | |
| 175 | } | |
| 176 | #------------------------------------------------------------------------------ | |
| 177 | # Spreadsheet::ParseExcel->OpName | |
| 178 | #------------------------------------------------------------------------------ | |
| 179 | sub OpName($) { | |
| 180 | my($bOp)=@_; | |
| 181 | return (defined $NameTbl{$bOp})? $NameTbl{$bOp}: 'undef'; | |
| 182 | } | |
| 183 | 1; | |
| 184 | __END__ | |
| 185 |
| 0 | # Spreadsheet::ParseExcel::FmtDefault | |
| 1 | # by Kawai, Takanori (Hippo2000) 2001.2.2 | |
| 2 | # This Program is ALPHA version. | |
| 3 | #============================================================================== | |
| 4 | package Spreadsheet::ParseExcel::FmtDefault; | |
| 5 | require Exporter; | |
| 6 | use strict; | |
| 7 | use Spreadsheet::ParseExcel::Utility qw(ExcelFmt); | |
| 8 | use vars qw($VERSION @ISA); | |
| 9 | @ISA = qw(Exporter); | |
| 10 | $VERSION = '0.05'; # | |
| 11 | ||
| 12 | my %hFmtDefault = ( | |
| 13 | 0x00 => '@', | |
| 14 | 0x01 => '0', | |
| 15 | 0x02 => '0.00', | |
| 16 | 0x03 => '#,##0', | |
| 17 | 0x04 => '#,##0.00', | |
| 18 | 0x05 => '($#,##0_);($#,##0)', | |
| 19 | 0x06 => '($#,##0_);[RED]($#,##0)', | |
| 20 | 0x07 => '($#,##0.00_);($#,##0.00_)', | |
| 21 | 0x08 => '($#,##0.00_);[RED]($#,##0.00_)', | |
| 22 | 0x09 => '0%', | |
| 23 | 0x0A => '0.00%', | |
| 24 | 0x0B => '0.00E+00', | |
| 25 | 0x0C => '# ?/?', | |
| 26 | 0x0D => '# ??/??', | |
| 27 | 0x0E => 'm-d-yy', | |
| 28 | 0x0F => 'd-mmm-yy', | |
| 29 | 0x10 => 'd-mmm', | |
| 30 | 0x11 => 'mmm-yy', | |
| 31 | 0x12 => 'h:mm AM/PM', | |
| 32 | 0x13 => 'h:mm:ss AM/PM', | |
| 33 | 0x14 => 'h:mm', | |
| 34 | 0x15 => 'h:mm:ss', | |
| 35 | 0x16 => 'm-d-yy h:mm', | |
| 36 | #0x17-0x24 -- Differs in Natinal | |
| 37 | 0x25 => '(#,##0_);(#,##0)', | |
| 38 | 0x26 => '(#,##0_);[RED](#,##0)', | |
| 39 | 0x27 => '(#,##0.00);(#,##0.00)', | |
| 40 | 0x28 => '(#,##0.00);[RED](#,##0.00)', | |
| 41 | 0x29 => '_(*#,##0_);_(*(#,##0);_(*"-"_);_(@_)', | |
| 42 | 0x2A => '_($*#,##0_);_($*(#,##0);_(*"-"_);_(@_)', | |
| 43 | 0x2B => '_(*#,##0.00_);_(*(#,##0.00);_(*"-"??_);_(@_)', | |
| 44 | 0x2C => '_($*#,##0.00_);_($*(#,##0.00);_(*"-"??_);_(@_)', | |
| 45 | 0x2D => 'mm:ss', | |
| 46 | 0x2E => '[h]:mm:ss', | |
| 47 | 0x2F => 'mm:ss.0', | |
| 48 | 0x30 => '##0.0E+0', | |
| 49 | 0x31 => '@', | |
| 50 | ); | |
| 51 | #------------------------------------------------------------------------------ | |
| 52 | # new (for Spreadsheet::ParseExcel::FmtDefault) | |
| 53 | #------------------------------------------------------------------------------ | |
| 54 | sub new($;%) { | |
| 55 | my($sPkg, %hKey) = @_; | |
| 56 | my $oThis={ | |
| 57 | }; | |
| 58 | bless $oThis; | |
| 59 | return $oThis; | |
| 60 | } | |
| 61 | #------------------------------------------------------------------------------ | |
| 62 | # TextFmt (for Spreadsheet::ParseExcel::FmtDefault) | |
| 63 | #------------------------------------------------------------------------------ | |
| 64 | sub TextFmt($$;$) { | |
| 65 | my($oThis, $sTxt, $sCode) =@_; | |
| 66 | return $sTxt if((! defined($sCode)) || ($sCode eq '_native_')); | |
| 67 | return pack('C*', unpack('n*', $sTxt)); | |
| 68 | } | |
| 69 | #------------------------------------------------------------------------------ | |
| 70 | # FmtStringDef (for Spreadsheet::ParseExcel::FmtDefault) | |
| 71 | #------------------------------------------------------------------------------ | |
| 72 | sub FmtStringDef($$$;$) { | |
| 73 | my($oThis, $iFmtIdx, $oBook, $rhFmt) =@_; | |
| 74 | my $sFmtStr = $oBook->{FormatStr}->{$iFmtIdx}; | |
| 75 | ||
| 76 | if(!(defined($sFmtStr)) && defined($rhFmt)) { | |
| 77 | $sFmtStr = $rhFmt->{$iFmtIdx}; | |
| 78 | } | |
| 79 | $sFmtStr = $hFmtDefault{$iFmtIdx} unless($sFmtStr); | |
| 80 | return $sFmtStr; | |
| 81 | } | |
| 82 | #------------------------------------------------------------------------------ | |
| 83 | # FmtString (for Spreadsheet::ParseExcel::FmtDefault) | |
| 84 | #------------------------------------------------------------------------------ | |
| 85 | sub FmtString($$$) { | |
| 86 | my($oThis, $oCell, $oBook) =@_; | |
| 87 | ||
| 88 | my $sFmtStr = $oThis->FmtStringDef( | |
| 89 | $oBook->{Format}[$oCell->{FormatNo}]->{FmtIdx}, $oBook); | |
| 90 | ||
| 91 | unless(defined($sFmtStr)) { | |
| 92 | if ($oCell->{Type} eq 'Numeric') { | |
| 93 | if(int($oCell->{Val}) != $oCell->{Val}) { | |
| 94 | $sFmtStr = '0.00'; | |
| 95 | } | |
| 96 | else { | |
| 97 | $sFmtStr = '0'; | |
| 98 | } | |
| 99 | } | |
| 100 | elsif($oCell->{Type} eq 'Date') { | |
| 101 | if(int($oCell->{Val}) <= 0) { | |
| 102 | $sFmtStr = 'h:mm:ss'; | |
| 103 | } | |
| 104 | else { | |
| 105 | $sFmtStr = 'm-d-yy'; | |
| 106 | } | |
| 107 | } | |
| 108 | else { | |
| 109 | $sFmtStr = '@'; | |
| 110 | } | |
| 111 | } | |
| 112 | return $sFmtStr; | |
| 113 | } | |
| 114 | #------------------------------------------------------------------------------ | |
| 115 | # ValFmt (for Spreadsheet::ParseExcel::FmtDefault) | |
| 116 | #------------------------------------------------------------------------------ | |
| 117 | sub ValFmt($$$) { | |
| 118 | my($oThis, $oCell, $oBook) =@_; | |
| 119 | ||
| 120 | my($Dt, $iFmtIdx, $iNumeric, $Flg1904); | |
| 121 | ||
| 122 | if ($oCell->{Type} eq 'Text') { | |
| 123 | $Dt = ((defined $oCell->{Val}) && ($oCell->{Val} ne ''))? | |
| 124 | $oThis->TextFmt($oCell->{Val}, $oCell->{Code}):''; | |
| 125 | } | |
| 126 | else { | |
| 127 | $Dt = $oCell->{Val}; | |
| 128 | } | |
| 129 | $Flg1904 = $oBook->{Flg1904}; | |
| 130 | my $sFmtStr = $oThis->FmtString($oCell, $oBook); | |
| 131 | return ExcelFmt($sFmtStr, $Dt, $Flg1904, $oCell->{Type}); | |
| 132 | } | |
| 133 | #------------------------------------------------------------------------------ | |
| 134 | # ChkType (for Spreadsheet::ParseExcel::FmtDefault) | |
| 135 | #------------------------------------------------------------------------------ | |
| 136 | sub ChkType($$$) { | |
| 137 | my($oPkg, $iNumeric, $iFmtIdx) =@_; | |
| 138 | if ($iNumeric) { | |
| 139 | if((($iFmtIdx >= 0x0E) && ($iFmtIdx <= 0x16)) || | |
| 140 | (($iFmtIdx >= 0x2D) && ($iFmtIdx <= 0x2F))) { | |
| 141 | return "Date"; | |
| 142 | } | |
| 143 | else { | |
| 144 | return "Numeric"; | |
| 145 | } | |
| 146 | } | |
| 147 | else { | |
| 148 | return "Text"; | |
| 149 | } | |
| 150 | } | |
| 151 | 1; |
| 0 | # Spreadsheet::ParseExcel::FmtJapan | |
| 1 | # by Kawai, Takanori (Hippo2000) 2001.2.2 | |
| 2 | # This Program is ALPHA version. | |
| 3 | #============================================================================== | |
| 4 | package Spreadsheet::ParseExcel::FmtJapan; | |
| 5 | require Exporter; | |
| 6 | use strict; | |
| 7 | use Spreadsheet::ParseExcel::FmtDefault; | |
| 8 | use Jcode; | |
| 9 | use vars qw($VERSION @ISA); | |
| 10 | @ISA = qw(Spreadsheet::ParseExcel::FmtDefault Exporter); | |
| 11 | ||
| 12 | $VERSION = '0.05'; # | |
| 13 | my %hFmtJapan = ( | |
| 14 | 0x00 => '@', | |
| 15 | 0x01 => '0', | |
| 16 | 0x02 => '0.00', | |
| 17 | 0x03 => '#,##0', | |
| 18 | 0x04 => '#,##0.00', | |
| 19 | 0x05 => '(\\#,##0_);(\\#,##0)', | |
| 20 | 0x06 => '(\\#,##0_);[RED](\\#,##0)', | |
| 21 | 0x07 => '(\\#,##0.00_);(\\#,##0.00_)', | |
| 22 | 0x08 => '(\\#,##0.00_);[RED](\\#,##0.00_)', | |
| 23 | 0x09 => '0%', | |
| 24 | 0x0A => '0.00%', | |
| 25 | 0x0B => '0.00E+00', | |
| 26 | 0x0C => '# ?/?', | |
| 27 | 0x0D => '# ??/??', | |
| 28 | # 0x0E => 'm/d/yy', | |
| 29 | 0x0E => 'yyyy/m/d', | |
| 30 | 0x0F => 'd-mmm-yy', | |
| 31 | 0x10 => 'd-mmm', | |
| 32 | 0x11 => 'mmm-yy', | |
| 33 | 0x12 => 'h:mm AM/PM', | |
| 34 | 0x13 => 'h:mm:ss AM/PM', | |
| 35 | 0x14 => 'h:mm', | |
| 36 | 0x15 => 'h:mm:ss', | |
| 37 | # 0x16 => 'm/d/yy h:mm', | |
| 38 | 0x16 => 'yyyy/m/d h:mm', | |
| 39 | ||
| 40 | #0x17-0x24 -- Differs in Natinal | |
| 41 | 0x1E => 'm/d/yy', | |
| 42 | 0x1F => 'yyyy"ǯ"m"·î"d"Æü"', | |
| 43 | 0x20 => 'h"»þ"mm"ʬ"', | |
| 44 | 0x21 => 'h"╩Ч"mm"й╛"ss"иц"', | |
| 45 | #0x17-0x24 -- Differs in Natinal | |
| 46 | 0x25 => '(#,##0_);(#,##0)', | |
| 47 | 0x26 => '(#,##0_);[RED](#,##0)', | |
| 48 | 0x27 => '(#,##0.00);(#,##0.00)', | |
| 49 | 0x28 => '(#,##0.00);[RED](#,##0.00)', | |
| 50 | 0x29 => '_(*#,##0_);_(*(#,##0);_(*"-"_);_(@_)', | |
| 51 | 0x2A => '_(\\*#,##0_);_(\\*(#,##0);_(*"-"_);_(@_)', | |
| 52 | 0x2B => '_(*#,##0.00_);_(*(#,##0.00);_(*"-"??_);_(@_)', | |
| 53 | 0x2C => '_(\\*#,##0.00_);_(\\*(#,##0.00);_(*"-"??_);_(@_)', | |
| 54 | 0x2D => 'mm:ss', | |
| 55 | 0x2E => '[h]:mm:ss', | |
| 56 | 0x2F => 'mm:ss.0', | |
| 57 | 0x30 => '##0.0E+0', | |
| 58 | 0x31 => '@', | |
| 59 | ||
| 60 | 0x37 => 'yyyy"ǯ"m"·î"', | |
| 61 | 0x38 => 'm"·î"d"Æü"', | |
| 62 | 0x39 => 'ge.m.d', | |
| 63 | 0x3A => 'ggge"ǯ"m"·î"d"Æü"', | |
| 64 | ); | |
| 65 | my $_Code; | |
| 66 | #------------------------------------------------------------------------------ | |
| 67 | # new (for Spreadsheet::ParseExcel::FmtJapan) | |
| 68 | #------------------------------------------------------------------------------ | |
| 69 | sub new($%) { | |
| 70 | my($sPkg, %hKey) = @_; | |
| 71 | my $oThis={ | |
| 72 | Code => $hKey{Code}, | |
| 73 | }; | |
| 74 | if($oThis->{Code}) { | |
| 75 | foreach my $sKey (keys %hFmtJapan) { | |
| 76 | $hFmtJapan{$sKey} = | |
| 77 | Jcode::convert($hFmtJapan{$sKey}, $oThis->{Code}, 'euc'); | |
| 78 | } | |
| 79 | $_Code = $oThis->{Code}; | |
| 80 | } | |
| 81 | bless $oThis; | |
| 82 | return $oThis; | |
| 83 | } | |
| 84 | #------------------------------------------------------------------------------ | |
| 85 | # TextFmt (for Spreadsheet::ParseExcel::FmtJapan) | |
| 86 | #------------------------------------------------------------------------------ | |
| 87 | sub TextFmt($$;$) { | |
| 88 | my($oThis, $sTxt, $sCode) =@_; | |
| 89 | ||
| 90 | if($oThis->{Code}) { | |
| 91 | if(! defined($sCode)) { | |
| 92 | $sTxt =~ s/(.)/\x00$1/sg; | |
| 93 | $sCode = 'ucs2'; | |
| 94 | } | |
| 95 | elsif($sCode eq '_native_') { | |
| 96 | $sCode = 'sjis'; | |
| 97 | } | |
| 98 | return Jcode::convert($sTxt, $oThis->{Code}, $sCode); | |
| 99 | } | |
| 100 | else { | |
| 101 | return $sTxt; | |
| 102 | } | |
| 103 | } | |
| 104 | #------------------------------------------------------------------------------ | |
| 105 | # FmtStringDef (for Spreadsheet::ParseExcel::FmtJapan) | |
| 106 | #------------------------------------------------------------------------------ | |
| 107 | sub FmtStringDef($$$) { | |
| 108 | my($oThis, $iFmtIdx, $oBook) =@_; | |
| 109 | return $oThis->SUPER::FmtStringDef($iFmtIdx, $oBook, \%hFmtJapan); | |
| 110 | } | |
| 111 | #------------------------------------------------------------------------------ | |
| 112 | # ValFmt (for Spreadsheet::ParseExcel::FmtJapan) | |
| 113 | #------------------------------------------------------------------------------ | |
| 114 | sub ValFmt($$$) { | |
| 115 | my($oThis, $oCell, $oBook) =@_; | |
| 116 | return $oThis->SUPER::ValFmt($oCell, $oBook); | |
| 117 | } | |
| 118 | #------------------------------------------------------------------------------ | |
| 119 | # ChkType (for Spreadsheet::ParseExcel::FmtJapan) | |
| 120 | #------------------------------------------------------------------------------ | |
| 121 | sub ChkType($$$) { | |
| 122 | my($oPkg, $iNumeric, $iFmtIdx) =@_; | |
| 123 | # Is there something special for Japan? | |
| 124 | return $oPkg->SUPER::ChkType($iNumeric, $iFmtIdx); | |
| 125 | } | |
| 126 | #------------------------------------------------------------------------------ | |
| 127 | # CnvNengo (for Spreadsheet::ParseExcel::FmtJapan) | |
| 128 | #------------------------------------------------------------------------------ | |
| 129 | sub CnvNengo($@) { | |
| 130 | my($iKind, @aTime) = @_; | |
| 131 | my $iWk = sprintf('%04d%02d%02d', $aTime[5], $aTime[4], $aTime[3]); | |
| 132 | if($iWk lt '19120730') { | |
| 133 | my $iY = $aTime[5] - 1867; | |
| 134 | return ($iKind == 1)? "M$iY" : | |
| 135 | Jcode::convert("ÿº£$iY", $_Code, 'euc'); | |
| 136 | } | |
| 137 | elsif($iWk lt '19261225') { | |
| 138 | my $iY = $aTime[5] - 1911; | |
| 139 | return ($iKind == 1)? "T$iY" : | |
| 140 | Jcode::convert("ÂçÀµ$iY", $_Code, 'euc'); | |
| 141 | } | |
| 142 | elsif($iWk lt '19890108' ) { | |
| 143 | my $iY = $aTime[5] - 1925; | |
| 144 | return ($iKind == 1)? "S$iY" : | |
| 145 | Jcode::convert("╬╪об$iY", $_Code, 'euc'); | |
| 146 | } | |
| 147 | else { | |
| 148 | my $iY = $aTime[5] - 1988; | |
| 149 | return ($iKind == 1)? "H$iY" : | |
| 150 | Jcode::convert("Ê¿À®$iY", $_Code, 'euc'); | |
| 151 | } | |
| 152 | } | |
| 153 | ||
| 154 | 1; |
| 0 | # Spreadsheet::ParseExcel::FmtJapan2 | |
| 1 | # by Kawai, Takanori (Hippo2000) 2001.2.2 | |
| 2 | # This Program is ALPHA version. | |
| 3 | #============================================================================== | |
| 4 | package Spreadsheet::ParseExcel::FmtJapan2; | |
| 5 | require Exporter; | |
| 6 | use strict; | |
| 7 | use Jcode; | |
| 8 | use Unicode::Map; | |
| 9 | use Spreadsheet::ParseExcel::FmtJapan; | |
| 10 | use vars qw($VERSION @ISA); | |
| 11 | @ISA = qw(Spreadsheet::ParseExcel::FmtJapan Exporter); | |
| 12 | $VERSION = '0.05'; # | |
| 13 | ||
| 14 | #------------------------------------------------------------------------------ | |
| 15 | # new (for Spreadsheet::ParseExcel::FmtJapan2) | |
| 16 | #------------------------------------------------------------------------------ | |
| 17 | sub new($%) { | |
| 18 | my($sPkg, %hKey) = @_; | |
| 19 | my $oMap = Unicode::Map->new('CP932Excel'); | |
| 20 | die "NO MAP FILE CP932Excel!!" | |
| 21 | unless(-r Unicode::Map->mapping("CP932Excel")); | |
| 22 | ||
| 23 | my $oThis={ | |
| 24 | Code => $hKey{Code}, | |
| 25 | _UniMap => $oMap, | |
| 26 | }; | |
| 27 | bless $oThis; | |
| 28 | $oThis->SUPER::new(%hKey); | |
| 29 | return $oThis; | |
| 30 | } | |
| 31 | #------------------------------------------------------------------------------ | |
| 32 | # TextFmt (for Spreadsheet::ParseExcel::FmtJapan2) | |
| 33 | #------------------------------------------------------------------------------ | |
| 34 | sub TextFmt($$;$) { | |
| 35 | my($oThis, $sTxt, $sCode) =@_; | |
| 36 | # $sCode = 'sjis' if((! defined($sCode)) || ($sCode eq '_native_')); | |
| 37 | if($oThis->{Code}) { | |
| 38 | if(! defined($sCode)) { | |
| 39 | $sTxt =~ s/(.)/\x00$1/sg; | |
| 40 | $sTxt = $oThis->{_UniMap}->from_unicode($sTxt); | |
| 41 | } | |
| 42 | elsif($sCode eq 'ucs2') { | |
| 43 | $sTxt = $oThis->{_UniMap}->from_unicode($sTxt); | |
| 44 | } | |
| 45 | return Jcode::convert($sTxt, $oThis->{Code}, 'sjis'); | |
| 46 | } | |
| 47 | else { | |
| 48 | return $sTxt; | |
| 49 | } | |
| 50 | } | |
| 51 | 1; |
| 0 | # Spreadsheet::ParseExcel::FmtUnicode | |
| 1 | # by Kawai, Takanori (Hippo2000) 2000.12.20 | |
| 2 | # 2001.2.2 | |
| 3 | # This Program is ALPHA version. | |
| 4 | #============================================================================== | |
| 5 | package Spreadsheet::ParseExcel::FmtUnicode; | |
| 6 | require Exporter; | |
| 7 | use strict; | |
| 8 | use Spreadsheet::ParseExcel::FmtDefault; | |
| 9 | use vars qw($VERSION @ISA); | |
| 10 | @ISA = qw(Spreadsheet::ParseExcel::FmtDefault Exporter); | |
| 11 | $VERSION = '0.05'; # | |
| 12 | use Unicode::Map; | |
| 13 | #------------------------------------------------------------------------------ | |
| 14 | # new (for Spreadsheet::ParseExcel::FmtUnicode) | |
| 15 | #------------------------------------------------------------------------------ | |
| 16 | sub new($%) { | |
| 17 | my($sPkg, %hKey) = @_; | |
| 18 | my $sMap = $hKey{Unicode_Map}; | |
| 19 | my $oMap; | |
| 20 | $oMap = Unicode::Map->new($sMap) if $sMap; | |
| 21 | my $oThis={ | |
| 22 | Unicode_Map => $sMap, | |
| 23 | _UniMap => $oMap, | |
| 24 | }; | |
| 25 | bless $oThis; | |
| 26 | return $oThis; | |
| 27 | } | |
| 28 | #------------------------------------------------------------------------------ | |
| 29 | # TextFmt (for Spreadsheet::ParseExcel::FmtUnicode) | |
| 30 | #------------------------------------------------------------------------------ | |
| 31 | sub TextFmt($$;$) { | |
| 32 | my($oThis, $sTxt, $sCode) =@_; | |
| 33 | if($oThis->{_UniMap}) { | |
| 34 | if(! defined($sCode)) { | |
| 35 | my $sSv = $sTxt; | |
| 36 | $sTxt =~ s/(.)/\x00$1/sg; | |
| 37 | $sTxt = $oThis->{_UniMap}->from_unicode($sTxt); | |
| 38 | $sTxt = $sSv unless($sTxt); | |
| 39 | } | |
| 40 | elsif($sCode eq 'ucs2') { | |
| 41 | $sTxt = $oThis->{_UniMap}->from_unicode($sTxt); | |
| 42 | } | |
| 43 | # $sTxt = $oThis->{_UniMap}->from_unicode($sTxt) | |
| 44 | # if(defined($sCode) && $sCode eq 'ucs2'); | |
| 45 | return $sTxt; | |
| 46 | } | |
| 47 | else { | |
| 48 | return $sTxt; | |
| 49 | } | |
| 50 | } | |
| 51 | 1; |
| 0 | # Spreadsheet::ParseExcel::SaveParser | |
| 1 | # by Kawai, Takanori (Hippo2000) 2001.5.1 | |
| 2 | # This Program is ALPHA version. | |
| 3 | #////////////////////////////////////////////////////////////////////////////// | |
| 4 | # Spreadsheet::ParseExcel:.SaveParser Objects | |
| 5 | #////////////////////////////////////////////////////////////////////////////// | |
| 6 | #============================================================================== | |
| 7 | # Spreadsheet::ParseExcel::SaveParser::Workbook | |
| 8 | #============================================================================== | |
| 9 | package Spreadsheet::ParseExcel::SaveParser::Workbook; | |
| 10 | require Exporter; | |
| 11 | use strict; | |
| 12 | use vars qw($VERSION @ISA); | |
| 13 | @ISA = qw(Spreadsheet::ParseExcel::Workbook Exporter); | |
| 14 | $VERSION = '0.05'; # | |
| 15 | sub new($$) { | |
| 16 | my($sPkg, $oBook) = @_; | |
| 17 | return undef unless(defined $oBook); | |
| 18 | my %oThis = %$oBook; | |
| 19 | bless \%oThis, $sPkg; | |
| 20 | ||
| 21 | # re-bless worksheets (and set their _Book properties !!!) | |
| 22 | my $sWkP = ref($sPkg) || "$sPkg"; | |
| 23 | $sWkP =~ s/Workbook$/Worksheet/; | |
| 24 | map { bless($_, $sWkP); } @{$oThis{Worksheet}}; | |
| 25 | map { $_->{_Book} = \%oThis; } @{$oThis{Worksheet}}; | |
| 26 | return \%oThis; | |
| 27 | } | |
| 28 | #------------------------------------------------------------------------------ | |
| 29 | # Parse (for Spreadsheet::ParseExcel::SaveParser::Workbook) | |
| 30 | #------------------------------------------------------------------------------ | |
| 31 | sub Parse($$;$) { | |
| 32 | my($sClass, $sFile, $oWkFmt)=@_; | |
| 33 | my $oBook = Spreadsheet::ParseExcel::Workbook->Parse($sFile, $oWkFmt); | |
| 34 | bless $oBook, $sClass; | |
| 35 | ||
| 36 | # re-bless worksheets (and set their _Book properties !!!) | |
| 37 | my $sWkP = ref($sClass) || "$sClass"; | |
| 38 | $sWkP =~ s/Workbook$/Worksheet/; | |
| 39 | map { bless($_, $sWkP); } @{$oBook->{Worksheet}}; | |
| 40 | map { $_->{_Book} = $oBook; } @{$oBook->{Worksheet}}; | |
| 41 | return $oBook; | |
| 42 | } | |
| 43 | #------------------------------------------------------------------------------ | |
| 44 | # SaveAs (for Spreadsheet::ParseExcel::SaveParser::Workbook) | |
| 45 | #------------------------------------------------------------------------------ | |
| 46 | sub SaveAs($$){ | |
| 47 | my ($oBook, $sName)=@_; | |
| 48 | # Create a new Excel workbook | |
| 49 | my $oWrEx = Spreadsheet::WriteExcel->new($sName); | |
| 50 | my %hFmt; | |
| 51 | ||
| 52 | my $iNo = 0; | |
| 53 | my @aAlH = ('left', 'left', 'center', 'right', 'fill', 'justify', 'merge', 'equal_space'); | |
| 54 | my @aAlV = ('top' , 'vcenter', 'bottom', 'vjustify', 'vequal_space'); | |
| 55 | ||
| 56 | foreach my $pFmt (@{$oBook->{Format}}) { | |
| 57 | my $oFmt = $oWrEx->addformat(); # Add Formats | |
| 58 | unless($pFmt->{Style}) { | |
| 59 | $hFmt{$iNo} = $oFmt; | |
| 60 | my $rFont = $pFmt->{Font}; | |
| 61 | ||
| 62 | $oFmt->set_font($rFont->{Name}); | |
| 63 | $oFmt->set_size($rFont->{Height}); | |
| 64 | $oFmt->set_color($rFont->{Color}); | |
| 65 | $oFmt->set_bold($rFont->{Bold}); | |
| 66 | $oFmt->set_italic($rFont->{Italic}); | |
| 67 | $oFmt->set_underline($rFont->{Underline}); | |
| 68 | $oFmt->set_font_strikeout($rFont->{Strikeout}); | |
| 69 | $oFmt->set_font_script($rFont->{Super}); | |
| 70 | ||
| 71 | $oFmt->set_hidden($rFont->{Hidden}); #Add | |
| 72 | ||
| 73 | $oFmt->set_align($aAlH[$pFmt->{AlignH}]); | |
| 74 | $oFmt->set_align($aAlV[$pFmt->{AlignV}]); | |
| 75 | if($pFmt->{Rotate}==0) { | |
| 76 | $oFmt->set_rotation(0); | |
| 77 | } | |
| 78 | elsif($pFmt->{Rotate}> 0) { # Mainly ==90 | |
| 79 | $oFmt->set_rotation(3); | |
| 80 | } | |
| 81 | elsif($pFmt->{Rotate} < 0) { # Mainly == -90 | |
| 82 | $oFmt->set_rotation(2); | |
| 83 | } | |
| 84 | $oFmt->set_num_format($oBook->{FmtClass}->FmtStringDef($pFmt->{FmtIdx}, $oBook)); | |
| 85 | ||
| 86 | $oFmt->set_text_wrap($pFmt->{Wrap}); | |
| 87 | ||
| 88 | $oFmt->set_pattern($pFmt->{Fill}->[0]); | |
| 89 | $oFmt->set_fg_color($pFmt->{Fill}->[1]) | |
| 90 | if(($pFmt->{Fill}->[1] >= 8) && ($pFmt->{Fill}->[1] <= 63)); | |
| 91 | $oFmt->set_bg_color($pFmt->{Fill}->[2]) | |
| 92 | if(($pFmt->{Fill}->[2] >= 8) && ($pFmt->{Fill}->[2] <= 63)); | |
| 93 | ||
| 94 | $oFmt->set_left (($pFmt->{BdrStyle}->[0]>7)? 3: $pFmt->{BdrStyle}->[0]); | |
| 95 | $oFmt->set_right (($pFmt->{BdrStyle}->[1]>7)? 3: $pFmt->{BdrStyle}->[1]); | |
| 96 | $oFmt->set_top (($pFmt->{BdrStyle}->[2]>7)? 3: $pFmt->{BdrStyle}->[2]); | |
| 97 | $oFmt->set_bottom(($pFmt->{BdrStyle}->[3]>7)? 3: $pFmt->{BdrStyle}->[3]); | |
| 98 | ||
| 99 | $oFmt->set_left_color ($pFmt->{BdrColor}->[0]) | |
| 100 | if(($pFmt->{BdrColor}->[0] >= 8) && ($pFmt->{BdrColor}->[0] <= 63)); | |
| 101 | $oFmt->set_right_color ($pFmt->{BdrColor}->[1]) | |
| 102 | if(($pFmt->{BdrColor}->[1] >= 8) && ($pFmt->{BdrColor}->[1] <= 63)); | |
| 103 | $oFmt->set_top_color ($pFmt->{BdrColor}->[2]) | |
| 104 | if(($pFmt->{BdrColor}->[2] >= 8) && ($pFmt->{BdrColor}->[2] <= 63)); | |
| 105 | $oFmt->set_bottom_color($pFmt->{BdrColor}->[3]) | |
| 106 | if(($pFmt->{BdrColor}->[3] >= 8) && ($pFmt->{BdrColor}->[3] <= 63)); | |
| 107 | } | |
| 108 | $iNo++; | |
| 109 | } | |
| 110 | for(my $iSheet=0; $iSheet < $oBook->{SheetCount} ; $iSheet++) { | |
| 111 | my $oWkS = $oBook->{Worksheet}[$iSheet]; | |
| 112 | my $oWrS = $oWrEx->addworksheet($oWkS->{Name}); | |
| 113 | #Landscape | |
| 114 | if(!$oWkS->{Landscape}) { # Landscape (0:Horizontal, 1:Vertical) | |
| 115 | $oWrS->set_landscape(); | |
| 116 | } | |
| 117 | else { | |
| 118 | $oWrS->set_portrait(); | |
| 119 | } | |
| 120 | if(($oWkS->{FitWidth}==1) and ($oWkS->{FitHeight}==1)) { | |
| 121 | # Pages on fit with width and Heigt | |
| 122 | $oWrS->fit_to_pages($oWkS->{FitWidth}, $oWkS->{FitHeight}); | |
| 123 | #Print Scale | |
| 124 | $oWrS->set_print_scale($oWkS->{Scale}); | |
| 125 | } | |
| 126 | else { | |
| 127 | #Print Scale | |
| 128 | $oWrS->set_print_scale($oWkS->{Scale}); | |
| 129 | # Pages on fit with width and Heigt | |
| 130 | $oWrS->fit_to_pages($oWkS->{FitWidth}, $oWkS->{FitHeight}); | |
| 131 | } | |
| 132 | # Paper Size | |
| 133 | $oWrS->set_paper($oWkS->{PaperSize}); | |
| 134 | # Margin | |
| 135 | $oWrS->set_margin_left($oWkS->{LeftMergin} / 2.55); | |
| 136 | $oWrS->set_margin_right($oWkS->{RightMergin} / 2.55); | |
| 137 | $oWrS->set_margin_top($oWkS->{TopMergin} / 2.55); | |
| 138 | $oWrS->set_margin_bottom($oWkS->{BottomMergin} / 2.55); | |
| 139 | # HCenter | |
| 140 | $oWrS->center_horizontally() if($oWkS->{HCenter}); | |
| 141 | # VCenter | |
| 142 | $oWrS->center_vertically() if($oWkS->{VCenter}); | |
| 143 | # Header, Footer | |
| 144 | $oWrS->set_header($oWkS->{Header}, $oWkS->{HeaderMergin}/2.55); | |
| 145 | $oWrS->set_footer($oWkS->{Footer}, $oWkS->{FooterMergin}/2.55); | |
| 146 | # Print Area | |
| 147 | if(ref($oBook->{PrintArea}[$iSheet]) eq 'ARRAY') { | |
| 148 | my $raP; | |
| 149 | for $raP (@{$oBook->{PrintArea}[$iSheet]}) { | |
| 150 | $oWrS->print_area(@$raP); | |
| 151 | } | |
| 152 | } | |
| 153 | ||
| 154 | # Print Title | |
| 155 | my $raW; | |
| 156 | foreach $raW (@{$oBook->{PrintTitle}[$iSheet]->{Row}}) { | |
| 157 | $oWrS->repeat_rows(@$raW); | |
| 158 | } | |
| 159 | foreach $raW (@{$oBook->{PrintTitle}[$iSheet]->{Column}}) { | |
| 160 | $oWrS->repeat_columns(@$raW); | |
| 161 | } | |
| 162 | # Print Gridlines | |
| 163 | if($oWkS->{PrintGrid}==1) { | |
| 164 | $oWrS->hide_gridlines(0); | |
| 165 | } | |
| 166 | else { | |
| 167 | $oWrS->hide_gridlines(1); | |
| 168 | } | |
| 169 | # Print Headings | |
| 170 | if($oWkS->{PrintHeaders}) { | |
| 171 | $oWrS->print_row_col_headers(); | |
| 172 | } | |
| 173 | # Horizontal Page Breaks | |
| 174 | $oWrS->set_h_pagebreaks(@{$oWkS->{HPageBreak}}); | |
| 175 | # Veritical Page Breaks | |
| 176 | $oWrS->set_v_pagebreaks(@{$oWkS->{VPageBreak}}); | |
| 177 | =pod | |
| 178 | ||
| 179 | PageStart => $oWkS->{PageStart}, # Page number for start | |
| 180 | UsePage => $oWkS->{UsePage}, # Use own start page number | |
| 181 | NoColor => $oWkS->{NoColor}, # Print in blcak-white | |
| 182 | Draft => $oWkS->{Draft}, # Print in draft mode | |
| 183 | Notes => $oWkS->{Notes}, # Print notes | |
| 184 | LeftToRight => $oWkS->{LeftToRight}, # Left to Right | |
| 185 | =cut | |
| 186 | for(my $iC = $oWkS->{MinCol} ; | |
| 187 | defined $oWkS->{MaxCol} && $iC <= $oWkS->{MaxCol} ; $iC++) { | |
| 188 | if(defined $oWkS->{ColWidth}[$iC]) { | |
| 189 | if($oWkS->{ColWidth}[$iC]>0) { | |
| 190 | $oWrS->set_column($iC, $iC, $oWkS->{ColWidth}[$iC]);#, undef, 1) ; | |
| 191 | } | |
| 192 | else { | |
| 193 | $oWrS->set_column($iC, $iC, 0, undef, 1) ; | |
| 194 | } | |
| 195 | } | |
| 196 | } | |
| 197 | for(my $iR = $oWkS->{MinRow} ; | |
| 198 | defined $oWkS->{MaxRow} && $iR <= $oWkS->{MaxRow} ; $iR++) { | |
| 199 | $oWrS->set_row($iR, $oWkS->{RowHeight}[$iR]); | |
| 200 | for(my $iC = $oWkS->{MinCol} ; | |
| 201 | defined $oWkS->{MaxCol} && $iC <= $oWkS->{MaxCol} ; $iC++) { | |
| 202 | ||
| 203 | my $oWkC = $oWkS->{Cells}[$iR][$iC]; | |
| 204 | if($oWkC) { | |
| 205 | if($oWkC->{Merged}) { | |
| 206 | my $oFmtN = $oWrEx->addformat(); | |
| 207 | $oFmtN->copy($hFmt{$oWkC->{FormatNo}}); | |
| 208 | $oFmtN->set_merge(1); | |
| 209 | $oWrS->write($iR , $iC, $oBook->{FmtClass}->TextFmt($oWkC->{Val}, $oWkC->{Code}), | |
| 210 | $oFmtN); | |
| 211 | } | |
| 212 | else { | |
| 213 | $oWrS->write($iR , $iC, $oBook->{FmtClass}->TextFmt($oWkC->{Val}, $oWkC->{Code}), | |
| 214 | $hFmt{$oWkC->{FormatNo}}); | |
| 215 | } | |
| 216 | } | |
| 217 | } | |
| 218 | } | |
| 219 | } | |
| 220 | return $oWrEx | |
| 221 | } | |
| 222 | #------------------------------------------------------------------------------ | |
| 223 | # AddWorksheet (for Spreadsheet::ParseExcel::SaveParser::Workbook) | |
| 224 | #------------------------------------------------------------------------------ | |
| 225 | sub AddWorksheet($$%) { | |
| 226 | my($oBook, $sName, %hAttr) = @_; | |
| 227 | $oBook->AddFormat if($#{$oBook->{Format}}<0); | |
| 228 | $hAttr{Name} ||= $sName; | |
| 229 | $hAttr{LeftMergin} ||= 0; | |
| 230 | $hAttr{RightMergin} ||= 0; | |
| 231 | $hAttr{TopMergin} ||= 0; | |
| 232 | $hAttr{BottomMergin} ||= 0; | |
| 233 | $hAttr{HeaderMergin} ||= 0; | |
| 234 | $hAttr{FooterMergin} ||= 0; | |
| 235 | $hAttr{FitWidth} ||= 0; | |
| 236 | $hAttr{FitHeight} ||= 0; | |
| 237 | $hAttr{PrintGrid} ||= 0; | |
| 238 | my $oWkS = Spreadsheet::ParseExcel::SaveParser::Worksheet->new(%hAttr); | |
| 239 | $oWkS->{_Book} = $oBook; | |
| 240 | $oWkS->{_SheetNo} = $oBook->{SheetCount}; | |
| 241 | $oBook->{Worksheet}[$oBook->{SheetCount}] = $oWkS; | |
| 242 | $oBook->{SheetCount}++; | |
| 243 | return $oWkS; #$oBook->{SheetCount} - 1; | |
| 244 | } | |
| 245 | #------------------------------------------------------------------------------ | |
| 246 | # AddFont (for Spreadsheet::ParseExcel::SaveParser::Workbook) | |
| 247 | #------------------------------------------------------------------------------ | |
| 248 | sub AddFont($%){ | |
| 249 | my ($oBook, %hAttr) = @_; | |
| 250 | $hAttr{Name} ||= 'Arial'; | |
| 251 | $hAttr{Height} ||= 10; | |
| 252 | $hAttr{Bold} ||= 0; | |
| 253 | $hAttr{Italic} ||= 0; | |
| 254 | $hAttr{Underline}||= 0; | |
| 255 | $hAttr{Strikeout}||= 0; | |
| 256 | $hAttr{Super} ||= 0; | |
| 257 | push @{$oBook->{Font}}, | |
| 258 | Spreadsheet::ParseExcel::Font->new(%hAttr); | |
| 259 | return $#{$oBook->{Font}}; | |
| 260 | } | |
| 261 | #------------------------------------------------------------------------------ | |
| 262 | # AddFormat (for Spreadsheet::ParseExcel::SaveParser::Workbook) | |
| 263 | #------------------------------------------------------------------------------ | |
| 264 | sub AddFormat($%){ | |
| 265 | my ($oBook, %hAttr) = @_; | |
| 266 | $hAttr{Fill} ||= [0, 0, 0]; | |
| 267 | $hAttr{BdrStyle} ||= [0, 0, 0, 0]; | |
| 268 | $hAttr{BdrColor} ||= [0, 0, 0, 0]; | |
| 269 | $hAttr{AlignH} ||= 0; | |
| 270 | $hAttr{AlignV} ||= 0; | |
| 271 | $hAttr{Rotate} ||= 0; | |
| 272 | $hAttr{Landscape} ||= 0; | |
| 273 | $hAttr{FmtIdx} ||= 0; | |
| 274 | if(!defined($hAttr{Font})) { | |
| 275 | my $oFont; | |
| 276 | if(defined $hAttr{FontNo}) { | |
| 277 | $oFont = $oBook->{Font}[$hAttr{FontNo}]; | |
| 278 | } | |
| 279 | elsif(!defined $oFont) { | |
| 280 | if($#{$oBook->{Font}}>=0) { | |
| 281 | $oFont = $oBook->{Font}[0]; | |
| 282 | } | |
| 283 | else { | |
| 284 | my $iNo = $oBook->AddFont; | |
| 285 | $oFont = $oBook->{Font}[$iNo]; | |
| 286 | } | |
| 287 | } | |
| 288 | $hAttr{Font} = $oFont; | |
| 289 | } | |
| 290 | push @{$oBook->{Format}}, | |
| 291 | Spreadsheet::ParseExcel::Format->new(%hAttr); | |
| 292 | return $#{$oBook->{Format}}; | |
| 293 | } | |
| 294 | #------------------------------------------------------------------------------ | |
| 295 | # AddCell (for Spreadsheet::ParseExcel::SaveParser::Workbook) | |
| 296 | #------------------------------------------------------------------------------ | |
| 297 | sub AddCell($$$$$$;$) { | |
| 298 | my($oBook, $iSheet, $iR, $iC, $sVal, $oCell, $sCode)=@_; | |
| 299 | my %rhKey; | |
| 300 | $oCell ||= 0; | |
| 301 | my $iFmt = (UNIVERSAL::isa($oCell, 'Spreadsheet::ParseExcel::Cell'))? | |
| 302 | $oCell->{FormatNo} : (ref($oCell))? 0: $oCell+0; | |
| 303 | $rhKey{FormatNo} = $iFmt; | |
| 304 | $rhKey{Format} = $oBook->{Format}[$iFmt]; | |
| 305 | $rhKey{Val} = $sVal; | |
| 306 | $rhKey{Code} = $sCode || '_native_'; | |
| 307 | $oBook->{_CurSheet} = $iSheet; | |
| 308 | my $oNewCell = Spreadsheet::ParseExcel::_NewCell($oBook, $iR, $iC, %rhKey); | |
| 309 | Spreadsheet::ParseExcel::_SetDimension($oBook, $iR, $iC, $iC); | |
| 310 | return $oNewCell; | |
| 311 | } | |
| 312 | 1; | |
| 313 | #============================================================================== | |
| 314 | # Spreadsheet::ParseExcel::SaveParser::Worksheet | |
| 315 | #============================================================================== | |
| 316 | package Spreadsheet::ParseExcel::SaveParser::Worksheet; | |
| 317 | require Exporter; | |
| 318 | use strict; | |
| 319 | use vars qw($VERSION @ISA); | |
| 320 | @ISA = qw(Spreadsheet::ParseExcel::Worksheet Exporter); | |
| 321 | sub new($%) { | |
| 322 | my ($sClass, %rhIni) = @_; | |
| 323 | $sClass->SUPER::new(%rhIni); # returns object | |
| 324 | } | |
| 325 | #------------------------------------------------------------------------------ | |
| 326 | # AddCell (for Spreadsheet::ParseExcel::SaveParser::Worksheet) | |
| 327 | #------------------------------------------------------------------------------ | |
| 328 | sub AddCell($$$$$;$) { | |
| 329 | my($oSelf, $iR, $iC, $sVal, $oCell, $sCode)=@_; | |
| 330 | $oSelf->{_Book}->AddCell($oSelf->{_SheetNo}, $iR, $iC, $sVal, $oCell, $sCode); | |
| 331 | } | |
| 332 | ||
| 333 | #============================================================================== | |
| 334 | # Spreadsheet::ParseExcel::SaveParser | |
| 335 | #============================================================================== | |
| 336 | package Spreadsheet::ParseExcel::SaveParser; | |
| 337 | require Exporter; | |
| 338 | use strict; | |
| 339 | use Spreadsheet::WriteExcel; | |
| 340 | use Spreadsheet::ParseExcel; | |
| 341 | use vars qw($VERSION @ISA); | |
| 342 | @ISA = qw(Spreadsheet::ParseExcel Exporter); | |
| 343 | $VERSION = '0.01'; # | |
| 344 | use constant MagicCol => 1.14; | |
| 345 | #------------------------------------------------------------------------------ | |
| 346 | # new (for Spreadsheet::ParseExcel::SaveParser) | |
| 347 | #------------------------------------------------------------------------------ | |
| 348 | sub new($%) { | |
| 349 | my($sPkg, %hKey) = @_; | |
| 350 | $sPkg->SUPER::new(%hKey); | |
| 351 | } | |
| 352 | #------------------------------------------------------------------------------ | |
| 353 | # Create | |
| 354 | #------------------------------------------------------------------------------ | |
| 355 | sub Create($;$) { | |
| 356 | my($oThis, $oWkFmt)=@_; | |
| 357 | #0. New $oBook | |
| 358 | my $oBook = Spreadsheet::ParseExcel::Workbook->new; | |
| 359 | $oBook->{SheetCount} = 0; | |
| 360 | #2. Ready for format | |
| 361 | if ($oWkFmt) { | |
| 362 | $oBook->{FmtClass} = $oWkFmt; | |
| 363 | } | |
| 364 | else { | |
| 365 | $oBook->{FmtClass} = new Spreadsheet::ParseExcel::FmtDefault; | |
| 366 | } | |
| 367 | return Spreadsheet::ParseExcel::SaveParser::Workbook->new($oBook); | |
| 368 | } | |
| 369 | #------------------------------------------------------------------------------ | |
| 370 | # Parse (for Spreadsheet::ParseExcel::SaveParser) | |
| 371 | #------------------------------------------------------------------------------ | |
| 372 | sub Parse($$;$) { | |
| 373 | my($oThis, $sFile, $oWkFmt)=@_; | |
| 374 | my $oBook = $oThis->SUPER::Parse($sFile, $oWkFmt); | |
| 375 | return undef unless(defined $oBook); | |
| 376 | return Spreadsheet::ParseExcel::SaveParser::Workbook->new($oBook); | |
| 377 | } | |
| 378 | #------------------------------------------------------------------------------ | |
| 379 | # SaveAs (for Spreadsheet::ParseExcel::SaveParser) | |
| 380 | #------------------------------------------------------------------------------ | |
| 381 | sub SaveAs($$$){ | |
| 382 | my ($oThis, $oBook, $sName)=@_; | |
| 383 | $oBook->SaveAs($sName); | |
| 384 | } | |
| 385 | 1; | |
| 386 | ||
| 387 | __END__ | |
| 388 | ||
| 389 | =head1 NAME | |
| 390 | ||
| 391 | Spreadsheet::ParseExcel::SaveParser - Expand of Spreadsheet::ParseExcel with Spreadsheet::WriteExcel | |
| 392 | ||
| 393 | =head1 SYNOPSIS | |
| 394 | ||
| 395 | #1. Write an Excel file with previous data | |
| 396 | use strict; | |
| 397 | use Spreadsheet::ParseExcel::SaveParser; | |
| 398 | my $oExcel = new Spreadsheet::ParseExcel::SaveParser; | |
| 399 | my $oBook = $oExcel->Parse('temp.xls'); | |
| 400 | #1.1.Update and Insert Cells | |
| 401 | my $iFmt = $oBook->{Worksheet}[0]->{Cells}[0][0]->{FormatNo}; | |
| 402 | $oBook->AddCell(0, 0, 0, 'No(UPD)', | |
| 403 | $oBook->{Worksheet}[0]->{Cells}[0][0]->{FormatNo}); | |
| 404 | $oBook->AddCell(0, 1, 0, '304', $oBook->{Worksheet}[0]->{Cells}[0][0]); | |
| 405 | $oBook->AddCell(0, 1, 1, 'Kawai,Takanori', $iFmt); | |
| 406 | #1.2.add new worksheet | |
| 407 | my $iWkN = $oBook->AddWorksheet('Test'); | |
| 408 | #1.3 Save | |
| 409 | $oExcel->SaveAs($oBook, 'temp.xls'); # as the same name | |
| 410 | $oExcel->SaveAs($oBook, 'temp1.xls'); # another name | |
| 411 | ||
| 412 | #2. Create new Excel file (most simple) | |
| 413 | use strict; | |
| 414 | use Spreadsheet::ParseExcel::SaveParser; | |
| 415 | my $oEx = new Spreadsheet::ParseExcel::SaveParser; | |
| 416 | my $oBook = $oEx->Create(); | |
| 417 | $oBook->AddFormat; | |
| 418 | $oBook->AddWorksheet('NewWS'); | |
| 419 | $oBook->AddCell(0, 0, 1, 'New Cell'); | |
| 420 | $oEx->SaveAs($oBook, 'new.xls'); | |
| 421 | ||
| 422 | #3. Create new Excel file(more complex) | |
| 423 | #!/usr/local/bin/perl | |
| 424 | use strict; | |
| 425 | use Spreadsheet::ParseExcel::SaveParser; | |
| 426 | my $oEx = new Spreadsheet::ParseExcel::SaveParser; | |
| 427 | my $oBook = $oEx->Create(); | |
| 428 | my $iF1 = $oBook->AddFont( | |
| 429 | Name => 'Arial', | |
| 430 | Height => 11, | |
| 431 | Bold => 1, #Bold | |
| 432 | Italic => 1, #Italic | |
| 433 | Underline => 0, | |
| 434 | Strikeout => 0, | |
| 435 | Super => 0, | |
| 436 | ); | |
| 437 | my $iFmt = | |
| 438 | $oBook->AddFormat( | |
| 439 | Font => $oBook->{Font}[$iF1], | |
| 440 | Fill => [1, 10, 0], # Filled with Red | |
| 441 | # cf. ParseExcel (@aColor) | |
| 442 | BdrStyle => [0, 1, 1, 0], #Border Right, Top | |
| 443 | BdrColor => [0, 11, 0, 0], # Right->Green | |
| 444 | ); | |
| 445 | $oBook->AddWorksheet('NewWS'); | |
| 446 | $oBook->AddCell(0, 0, 1, 'Cell', $iFmt); | |
| 447 | $oEx->SaveAs($oBook, 'new.xls'); | |
| 448 | ||
| 449 | I<new interface...> | |
| 450 | ||
| 451 | use strict; | |
| 452 | use Spreadsheet::ParseExcel::SaveParser; | |
| 453 | $oBook = | |
| 454 | Spreadsheet::ParseExcel::SaveParser::Workbook->Parse('Excel/Test97.xls'); | |
| 455 | my $oWs = $oBook->AddWorksheet('TEST1'); | |
| 456 | $oWs->AddCell(10, 1, 'New Cell'); | |
| 457 | $oBook->SaveAs('iftest.xls'); | |
| 458 | ||
| 459 | =head1 DESCRIPTION | |
| 460 | ||
| 461 | Spreadsheet::ParseExcel::SaveParser : Expand of Spreadsheet::ParseExcel with Spreadsheet::WriteExcel | |
| 462 | ||
| 463 | =head2 Functions | |
| 464 | ||
| 465 | =over 4 | |
| 466 | ||
| 467 | =item new | |
| 468 | ||
| 469 | I<$oExcel> = new Spreadsheet::ParseExcel::SaveParser(); | |
| 470 | ||
| 471 | Constructor. | |
| 472 | ||
| 473 | =item Parse | |
| 474 | ||
| 475 | I<$oWorkbook> = $oParse->Parse(I<$sFileName> [, I<$oFmt>]); | |
| 476 | ||
| 477 | return L<"Workbook"> object. | |
| 478 | if error occurs, returns undef. | |
| 479 | ||
| 480 | =over 4 | |
| 481 | ||
| 482 | =item I<$sFileName> | |
| 483 | ||
| 484 | name of the file to parse (Same as Spreadsheet::ParseExcel) | |
| 485 | ||
| 486 | From 0.12 (with OLE::Storage_Lite v.0.06), | |
| 487 | scalar reference of file contents (ex. \$sBuff) or | |
| 488 | IO::Handle object (inclucdng IO::File etc.) are also available. | |
| 489 | ||
| 490 | =item I<$oFmt> | |
| 491 | ||
| 492 | Formatter Class to format the value of cells. | |
| 493 | ||
| 494 | =back | |
| 495 | ||
| 496 | =item Create | |
| 497 | ||
| 498 | I<$oWorkbook> = $oParse->Create([I<$oFmt>]); | |
| 499 | ||
| 500 | return new L<"Workbook"> object. | |
| 501 | if error occurs, returns undef. | |
| 502 | ||
| 503 | =over 4 | |
| 504 | ||
| 505 | =item I<$oFmt> | |
| 506 | ||
| 507 | Formatter Class to format the value of cells. | |
| 508 | ||
| 509 | =back | |
| 510 | ||
| 511 | =item SaveAs | |
| 512 | ||
| 513 | I<$oWorkbook> = $oParse->SaveAs( $oBook, $sName); | |
| 514 | ||
| 515 | save $oBook image as an Excel file named $sName. | |
| 516 | ||
| 517 | =over 4 | |
| 518 | ||
| 519 | =item I<$oBook> | |
| 520 | ||
| 521 | An Excel Workbook object to save. | |
| 522 | ||
| 523 | =back | |
| 524 | ||
| 525 | =item I<$sName> | |
| 526 | ||
| 527 | Name of new Excel file. | |
| 528 | ||
| 529 | =back | |
| 530 | ||
| 531 | =head2 Workbook | |
| 532 | ||
| 533 | I<Spreadsheet::ParseExcel::SaveParser::Workbook> | |
| 534 | ||
| 535 | Workbook is a subclass of Spreadsheet::ParseExcel::Workbook. | |
| 536 | And has these methods : | |
| 537 | ||
| 538 | =over 4 | |
| 539 | ||
| 540 | =item AddWorksheet | |
| 541 | ||
| 542 | I<$oWorksheet> = $oBook->AddWorksheet($sName, %hProperty); | |
| 543 | ||
| 544 | Create new Worksheet(Spreadsheet::ParseExcel::Worksheet). | |
| 545 | ||
| 546 | =over 4 | |
| 547 | ||
| 548 | =item I<$sName> | |
| 549 | ||
| 550 | Name of new Worksheet | |
| 551 | ||
| 552 | =item I<$hProperty> | |
| 553 | ||
| 554 | Property of new Worksheet. | |
| 555 | ||
| 556 | =back | |
| 557 | ||
| 558 | =item AddFont | |
| 559 | ||
| 560 | I<$oWorksheet> = $oBook->AddFont(%hProperty); | |
| 561 | ||
| 562 | Create new Font(Spreadsheet::ParseExcel::Font). | |
| 563 | ||
| 564 | =over 4 | |
| 565 | ||
| 566 | =item I<$hProperty> | |
| 567 | ||
| 568 | Property of new Worksheet. | |
| 569 | ||
| 570 | =back | |
| 571 | ||
| 572 | =item AddFormat | |
| 573 | ||
| 574 | I<$oWorksheet> = $oBook->AddFormat(%hProperty); | |
| 575 | ||
| 576 | Create new Format(Spreadsheet::ParseExcel::Format). | |
| 577 | ||
| 578 | =over 4 | |
| 579 | ||
| 580 | =item I<$hProperty> | |
| 581 | ||
| 582 | Property of new Format. | |
| 583 | ||
| 584 | =back | |
| 585 | ||
| 586 | =item AddCell | |
| 587 | ||
| 588 | I<$oWorksheet> = $oBook->AddCell($iWorksheet, $iRow, $iCol, $sVal, $iFormat [, $sCode]); | |
| 589 | ||
| 590 | Create new Cell(Spreadsheet::ParseExcel::Cell). | |
| 591 | ||
| 592 | =over 4 | |
| 593 | ||
| 594 | =item I<$iWorksheet> | |
| 595 | ||
| 596 | Number of Worksheet | |
| 597 | ||
| 598 | =back | |
| 599 | ||
| 600 | =over 4 | |
| 601 | ||
| 602 | =item I<$iRow> | |
| 603 | ||
| 604 | Number of row | |
| 605 | ||
| 606 | =back | |
| 607 | ||
| 608 | =over 4 | |
| 609 | ||
| 610 | =item I<$sVal> | |
| 611 | ||
| 612 | Value of the cell. | |
| 613 | ||
| 614 | =back | |
| 615 | ||
| 616 | =over 4 | |
| 617 | ||
| 618 | =item I<$iFormat> | |
| 619 | ||
| 620 | Number of format for use. To specify just same as another cell, | |
| 621 | you can set it like below: | |
| 622 | ||
| 623 | ex. | |
| 624 | ||
| 625 | $oCell=$oWorksheet->{Cells}[0][0]; #Just a sample | |
| 626 | $oBook->AddCell(0, 1, 0, 'New One', $oCell->{FormatNo}); | |
| 627 | #or | |
| 628 | $oBook->AddCell(0, 1, 0, 'New One', $oCell); | |
| 629 | ||
| 630 | =back | |
| 631 | ||
| 632 | =over 4 | |
| 633 | ||
| 634 | =item I<$sCode> | |
| 635 | ||
| 636 | Character code | |
| 637 | ||
| 638 | =back | |
| 639 | ||
| 640 | =back | |
| 641 | ||
| 642 | =head2 Worksheet | |
| 643 | ||
| 644 | I<Spreadsheet::ParseExcel::SaveParser::Worksheet> | |
| 645 | ||
| 646 | Worksheet is a subclass of Spreadsheet::ParseExcel::Worksheet. | |
| 647 | And has these methods : | |
| 648 | ||
| 649 | =over 4 | |
| 650 | ||
| 651 | =item AddCell | |
| 652 | ||
| 653 | I<$oWorksheet> = $oWkSheet->AddCell($iRow, $iCol, $sVal, $iFormat [, $sCode]); | |
| 654 | ||
| 655 | Create new Cell(Spreadsheet::ParseExcel::Cell). | |
| 656 | ||
| 657 | =over 4 | |
| 658 | ||
| 659 | =item I<$iRow> | |
| 660 | ||
| 661 | Number of row | |
| 662 | ||
| 663 | =back | |
| 664 | ||
| 665 | =over 4 | |
| 666 | ||
| 667 | =item I<$sVal> | |
| 668 | ||
| 669 | Value of the cell. | |
| 670 | ||
| 671 | =back | |
| 672 | ||
| 673 | =over 4 | |
| 674 | ||
| 675 | =item I<$iFormat> | |
| 676 | ||
| 677 | Number of format for use. To specify just same as another cell, | |
| 678 | you can set it like below: | |
| 679 | ||
| 680 | ex. | |
| 681 | ||
| 682 | $oCell=$oWorksheet->{Cells}[0][0]; #Just a sample | |
| 683 | $oWorksheet->AddCell(1, 0, 'New One', $oCell->{FormatNo}); | |
| 684 | #or | |
| 685 | $oWorksheet->AddCell(1, 0, 'New One', $oCell); | |
| 686 | ||
| 687 | =back | |
| 688 | ||
| 689 | =over 4 | |
| 690 | ||
| 691 | =item I<$sCode> | |
| 692 | ||
| 693 | Character code | |
| 694 | ||
| 695 | =back | |
| 696 | ||
| 697 | =back | |
| 698 | ||
| 699 | =head1 MORE INFORMATION | |
| 700 | ||
| 701 | Please visit my Wiki page. | |
| 702 | I'll add sample at : | |
| 703 | http://www.hippo2000.info/cgi-bin/KbWikiE/KbWiki.pl | |
| 704 | ||
| 705 | =head1 Known Problem | |
| 706 | ||
| 707 | -Only last print area will remain. (Others will be removed) | |
| 708 | ||
| 709 | =head1 AUTHOR | |
| 710 | ||
| 711 | Kawai Takanori (Hippo2000) kwitknr@cpan.org | |
| 712 | ||
| 713 | http://member.nifty.ne.jp/hippo2000/ (Japanese) | |
| 714 | http://member.nifty.ne.jp/hippo2000/index_e.htm (English) | |
| 715 | ||
| 716 | =head1 SEE ALSO | |
| 717 | ||
| 718 | XLHTML, OLE::Storage, Spreadsheet::WriteExcel, OLE::Storage_Lite | |
| 719 | ||
| 720 | This module is based on herbert within OLE::Storage and XLHTML. | |
| 721 | ||
| 722 | =head1 COPYRIGHT | |
| 723 | ||
| 724 | Copyright (c) 2000-2002 Kawai Takanori and Nippon-RAD Co. OP Division | |
| 725 | All rights reserved. | |
| 726 | ||
| 727 | You may distribute under the terms of either the GNU General Public | |
| 728 | License or the Artistic License, as specified in the Perl README file. | |
| 729 | ||
| 730 | =head1 ACKNOWLEDGEMENTS | |
| 731 | ||
| 732 | First of all, I would like to acknowledge valuable program and modules : | |
| 733 | XHTML, OLE::Storage and Spreadsheet::WriteExcel. | |
| 734 | ||
| 735 | In no particular order: Yamaji Haruna, Simamoto Takesi, Noguchi Harumi, | |
| 736 | Ikezawa Kazuhiro, Suwazono Shugo, Hirofumi Morisada, Michael Edwards, Kim Namusk | |
| 737 | and many many people + Kawai Mikako. | |
| 738 | ||
| 739 | =cut |
| 0 | # Spreadsheet::ParseExcel::Utility | |
| 1 | # by Kawai, Takanori (Hippo2000) 2001.2.2 | |
| 2 | # This Program is ALPHA version. | |
| 3 | #============================================================================== | |
| 4 | # Spreadsheet::ParseExcel::Utility; | |
| 5 | #============================================================================== | |
| 6 | package Spreadsheet::ParseExcel::Utility; | |
| 7 | require Exporter; | |
| 8 | use strict; | |
| 9 | use vars qw($VERSION @ISA @EXPORT_OK); | |
| 10 | @ISA = qw(Exporter); | |
| 11 | @EXPORT_OK = qw(ExcelFmt LocaltimeExcel ExcelLocaltime | |
| 12 | col2int int2col sheetRef xls2csv); | |
| 13 | $VERSION=0.06; | |
| 14 | #my $sNUMEXP = '^[+-]?\d+(\.\d+)?$'; | |
| 15 | #my $sNUMEXP = '(^[+-]?\d+(\.\d+)?$)|(^[+-]?\d\.*(\d+)[eE][+-](\d+))$'; | |
| 16 | my $sNUMEXP = '(^[+-]?\d+(\.\d+)?$)|(^[+-]?\d+\.?(\d*)[eE][+-](\d+))$'; | |
| 17 | ||
| 18 | #ProtoTypes | |
| 19 | sub ExcelFmt($$;$$); | |
| 20 | sub LocaltimeExcel($$$$$$;$$); | |
| 21 | sub ExcelLocaltime($;$); | |
| 22 | sub AddComma($); | |
| 23 | sub MakeBun($$;$); | |
| 24 | sub MakeE($$); | |
| 25 | sub LeapYear($); | |
| 26 | ||
| 27 | #------------------------------------------------------------------------------ | |
| 28 | # ExcelFmt (for Spreadsheet::ParseExcel::Utility) | |
| 29 | #------------------------------------------------------------------------------ | |
| 30 | sub ExcelFmt($$;$$) { | |
| 31 | my($sFmt, $iData, $i1904, $sType) =@_; | |
| 32 | my $sCond; | |
| 33 | my $sWkF =''; | |
| 34 | my $sRes=''; | |
| 35 | #1. Get Condition | |
| 36 | if($sFmt=~/^\[([<>=][^\]]+)\](.*)$/) { | |
| 37 | $sCond = $1; | |
| 38 | $sFmt = $2; | |
| 39 | } | |
| 40 | $sFmt =~ s/_/ /g; | |
| 41 | ||
| 42 | my @sFmtWk; | |
| 43 | my $sFmtObj; | |
| 44 | my $iFmtPos=0; | |
| 45 | my $iDblQ=0; | |
| 46 | my $iQ = 0; | |
| 47 | foreach my $sWk (split //, $sFmt) { | |
| 48 | if($iDblQ or $iQ) { | |
| 49 | $sFmtWk[$iFmtPos] .=$sWk; | |
| 50 | $iDblQ = 0 if($sWk eq '"'); | |
| 51 | $iQ = 0; | |
| 52 | next; | |
| 53 | } | |
| 54 | ||
| 55 | if($sWk eq ';') { | |
| 56 | $iFmtPos++; | |
| 57 | next; | |
| 58 | } | |
| 59 | elsif($sWk eq '"') { | |
| 60 | $iDblQ = 1; | |
| 61 | } | |
| 62 | elsif($sWk eq '!') { | |
| 63 | $iQ = 1; | |
| 64 | } | |
| 65 | elsif($sWk eq '\\') { | |
| 66 | $iQ = 1; | |
| 67 | # next; | |
| 68 | } | |
| 69 | elsif($sWk eq '(') { #Skip? | |
| 70 | next; | |
| 71 | } | |
| 72 | elsif($sWk eq ')') { #Skip? | |
| 73 | next; | |
| 74 | } | |
| 75 | $sFmtWk[$iFmtPos] .=$sWk; | |
| 76 | } | |
| 77 | #Get FmtString | |
| 78 | if(scalar(@sFmtWk)>1) { | |
| 79 | if($sCond) { | |
| 80 | $sFmtObj = $sFmtWk[((eval(qq/"$iData" $sCond/))? 0: 1)]; | |
| 81 | } | |
| 82 | else { | |
| 83 | my $iWk = ($iData =~/$sNUMEXP/)? $iData: 0; | |
| 84 | # $iData = abs($iData) if($iWk !=0); | |
| 85 | if(scalar(@sFmtWk)==2) { | |
| 86 | $sFmtObj = $sFmtWk[(($iWk>=0)? 0: 1)]; | |
| 87 | } | |
| 88 | elsif(scalar(@sFmtWk)==3) { | |
| 89 | $sFmtObj = $sFmtWk[(($iWk>0)? 0: (($iWk<0)? 1: 2))]; | |
| 90 | } | |
| 91 | else { | |
| 92 | if($iData =~/$sNUMEXP/) { | |
| 93 | $sFmtObj = $sFmtWk[(($iWk>0)? 0: (($iWk<0)? 1: 2))]; | |
| 94 | } | |
| 95 | else { | |
| 96 | $sFmtObj = $sFmtWk[ 3]; | |
| 97 | } | |
| 98 | } | |
| 99 | } | |
| 100 | } | |
| 101 | else { | |
| 102 | $sFmtObj = $sFmtWk[0]; | |
| 103 | } | |
| 104 | ||
| 105 | my $sColor; | |
| 106 | if($sFmtObj =~ /^(\[[^hm\[\]]*\])/) { | |
| 107 | $sColor = $1; | |
| 108 | $sFmtObj = substr($sFmtObj, length($sColor)); | |
| 109 | chop($sColor); | |
| 110 | $sColor = substr($sColor, 1); | |
| 111 | } | |
| 112 | #print "FMT:$sFmtObj Co:$sColor\n"; | |
| 113 | ||
| 114 | #3.Build Data | |
| 115 | my $iFmtMode=0; #1:Number, 2:Date | |
| 116 | my $i=0; | |
| 117 | my $ir=0; | |
| 118 | my $sFmtWk; | |
| 119 | my @aRep = (); | |
| 120 | my $sFmtRes=''; | |
| 121 | ||
| 122 | my $iFflg = -1; | |
| 123 | my $iRpos = -1; | |
| 124 | my $iCmmCnt = 0; | |
| 125 | my $iBunFlg = 0; | |
| 126 | my $iFugouFlg = 0; | |
| 127 | my $iPer = 0; | |
| 128 | my $iAm=0; | |
| 129 | my $iSt; | |
| 130 | ||
| 131 | while($i<length($sFmtObj)) { | |
| 132 | $iSt = $i; | |
| 133 | my $sWk = substr($sFmtObj, $i, 1); | |
| 134 | ||
| 135 | if($sWk !~ /[#0\+\-\.\?eE\,\%]/) { | |
| 136 | if($iFflg != -1) { | |
| 137 | push @aRep, [substr($sFmtObj, $iFflg, $i-$iFflg), | |
| 138 | $iRpos, $i-$iFflg]; | |
| 139 | $iFflg= -1; | |
| 140 | } | |
| 141 | } | |
| 142 | ||
| 143 | if($sWk eq '"') { | |
| 144 | $iDblQ = $iDblQ? 0: 1; | |
| 145 | $i++; | |
| 146 | next; | |
| 147 | } | |
| 148 | elsif($sWk eq '!') { | |
| 149 | $iQ = 1; | |
| 150 | $i++; | |
| 151 | next; | |
| 152 | } | |
| 153 | elsif($sWk eq '\\') { | |
| 154 | if($iQ == 1) { | |
| 155 | } | |
| 156 | else { | |
| 157 | $iQ = 1; | |
| 158 | $i++; | |
| 159 | next; | |
| 160 | } | |
| 161 | } | |
| 162 | #print "WK:", ord($sWk), " $iFmtMode \n"; | |
| 163 | #print "DEF1: $iDblQ DEF2: $iQ\n"; | |
| 164 | if((defined($iDblQ) and ($iDblQ)) or (defined($iQ) and ($iQ))) { | |
| 165 | $iQ = 0; | |
| 166 | if(($iFmtMode != 2) and | |
| 167 | ((substr($sFmtObj, $i, 2) eq "\x81\xA2") || | |
| 168 | (substr($sFmtObj, $i, 2) eq "\x81\xA3") || | |
| 169 | (substr($sFmtObj, $i, 2) eq "\xA2\xA4") || | |
| 170 | (substr($sFmtObj, $i, 2) eq "\xA2\xA5")) | |
| 171 | ){ | |
| 172 | #print "PUSH:", unpack("H*", substr($sFmtObj, $i, 2)), "\n"; | |
| 173 | push @aRep, [substr($sFmtObj, $i, 2), | |
| 174 | length($sFmtRes), 2]; | |
| 175 | $iFugouFlg = 1; | |
| 176 | $i+=2; | |
| 177 | } | |
| 178 | else{ | |
| 179 | $i++; | |
| 180 | } | |
| 181 | } | |
| 182 | elsif(($sWk =~ /[#0\+\.\?eE\,\%]/) || | |
| 183 | (($iFmtMode != 2) and | |
| 184 | (($sWk eq '-') || ($sWk eq '(') || ($sWk eq ')'))) | |
| 185 | ) { | |
| 186 | $iFmtMode = 1 unless($iFmtMode); | |
| 187 | if(substr($sFmtObj, $i, 1) =~ /[#0]/) { | |
| 188 | if(substr($sFmtObj, $i) =~ /^([#0]+)([\.]?)([0#]*)([eE])([\+\-])([0#]+)/){ | |
| 189 | push @aRep, [substr($sFmtObj, $i, length($&)), $i, length($&)]; | |
| 190 | $i +=length($&); | |
| 191 | } | |
| 192 | else{ | |
| 193 | if($iFflg==-1) { | |
| 194 | $iFflg = $i; | |
| 195 | $iRpos = length($sFmtRes); | |
| 196 | } | |
| 197 | } | |
| 198 | } | |
| 199 | elsif(substr($sFmtObj, $i, 1) eq '?') { | |
| 200 | if($iFflg != -1) { | |
| 201 | push @aRep, [substr($sFmtObj, $iFflg, $i-$iFflg+1), | |
| 202 | $iRpos, $i-$iFflg+1]; | |
| 203 | } | |
| 204 | $iFflg = $i; | |
| 205 | while($i<length($sFmtObj)) { | |
| 206 | if (substr($sFmtObj, $i, 1) eq '/'){ | |
| 207 | $iBunFlg = 1; | |
| 208 | } | |
| 209 | elsif (substr($sFmtObj, $i, 1) eq '?'){ | |
| 210 | ; | |
| 211 | } | |
| 212 | else { | |
| 213 | if(($iBunFlg) && (substr($sFmtObj, $i, 1) =~ /[0-9]/)) { | |
| 214 | ; | |
| 215 | } | |
| 216 | else { | |
| 217 | last; | |
| 218 | } | |
| 219 | } | |
| 220 | $i++; | |
| 221 | } | |
| 222 | $i--; | |
| 223 | push @aRep, [substr($sFmtObj, $iFflg, $i-$iFflg+1), | |
| 224 | length($sFmtRes), $i-$iFflg+1]; | |
| 225 | $iFflg = -1; | |
| 226 | } | |
| 227 | elsif(substr($sFmtObj, $i, 3) =~ /^[eE][\+\-][0#]$/) { | |
| 228 | if(substr($sFmtObj, $i) =~ /([eE])([\+\-])([0#]+)/){ | |
| 229 | push @aRep, [substr($sFmtObj, $i, length($&)), $i, length($&)]; | |
| 230 | $i +=length($&); | |
| 231 | } | |
| 232 | $iFflg = -1; | |
| 233 | } | |
| 234 | else { | |
| 235 | if($iFflg != -1) { | |
| 236 | push @aRep, [substr($sFmtObj, $iFflg, $i-$iFflg), | |
| 237 | $iRpos, $i-$iFflg]; | |
| 238 | $iFflg= -1; | |
| 239 | } | |
| 240 | if(substr($sFmtObj, $i, 1) =~ /[\+\-]/) { | |
| 241 | push @aRep, [substr($sFmtObj, $i, 1), | |
| 242 | length($sFmtRes), 1]; | |
| 243 | $iFugouFlg = 1; | |
| 244 | } | |
| 245 | elsif(substr($sFmtObj, $i, 1) eq '.') { | |
| 246 | push @aRep, [substr($sFmtObj, $i, 1), | |
| 247 | length($sFmtRes), 1]; | |
| 248 | } | |
| 249 | elsif(substr($sFmtObj, $i, 1) eq ',') { | |
| 250 | $iCmmCnt++; | |
| 251 | push @aRep, [substr($sFmtObj, $i, 1), | |
| 252 | length($sFmtRes), 1]; | |
| 253 | } | |
| 254 | elsif(substr($sFmtObj, $i, 1) eq '%') { | |
| 255 | $iPer = 1; | |
| 256 | } | |
| 257 | elsif((substr($sFmtObj, $i, 1) eq '(') || | |
| 258 | (substr($sFmtObj, $i, 1) eq ')')) { | |
| 259 | push @aRep, [substr($sFmtObj, $i, 1), | |
| 260 | length($sFmtRes), 1]; | |
| 261 | $iFugouFlg = 1; | |
| 262 | } | |
| 263 | } | |
| 264 | $i++; | |
| 265 | } | |
| 266 | elsif($sWk =~ /[ymdhsapg]/) { | |
| 267 | $iFmtMode = 2 unless($iFmtMode); | |
| 268 | if(substr($sFmtObj, $i, 5) =~ /am\/pm/i) { | |
| 269 | push @aRep, ['am/pm', length($sFmtRes), 5]; | |
| 270 | $iAm=1; | |
| 271 | $i+=5; | |
| 272 | } | |
| 273 | elsif(substr($sFmtObj, $i, 3) =~ /a\/p/i) { | |
| 274 | push @aRep, ['a/p', length($sFmtRes), 3]; | |
| 275 | $iAm=1; | |
| 276 | $i+=3; | |
| 277 | } | |
| 278 | elsif(substr($sFmtObj, $i, 5) eq 'mmmmm') { | |
| 279 | push @aRep, ['mmmmm', length($sFmtRes), 5]; | |
| 280 | $i+=5; | |
| 281 | } | |
| 282 | elsif((substr($sFmtObj, $i, 4) eq 'mmmm') || | |
| 283 | (substr($sFmtObj, $i, 4) eq 'dddd') || | |
| 284 | (substr($sFmtObj, $i, 4) eq 'yyyy') || | |
| 285 | (substr($sFmtObj, $i, 4) eq 'ggge') | |
| 286 | ) { | |
| 287 | push @aRep, [substr($sFmtObj, $i, 4), length($sFmtRes), 4]; | |
| 288 | $i+=4; | |
| 289 | } | |
| 290 | elsif((substr($sFmtObj, $i, 3) eq 'mmm') || | |
| 291 | (substr($sFmtObj, $i, 3) eq 'yyy')) { | |
| 292 | push @aRep, [substr($sFmtObj, $i, 3), length($sFmtRes), 3]; | |
| 293 | $i+=3; | |
| 294 | } | |
| 295 | elsif((substr($sFmtObj, $i, 2) eq 'yy') || | |
| 296 | (substr($sFmtObj, $i, 2) eq 'mm') || | |
| 297 | (substr($sFmtObj, $i, 2) eq 'dd') || | |
| 298 | (substr($sFmtObj, $i, 2) eq 'hh') || | |
| 299 | (substr($sFmtObj, $i, 2) eq 'ss') || | |
| 300 | (substr($sFmtObj, $i, 2) eq 'ge')) { | |
| 301 | if((substr($sFmtObj, $i, 2) eq 'mm') && | |
| 302 | ($#aRep>=0) && | |
| 303 | (($aRep[$#aRep]->[0] eq 'h') or ($aRep[$#aRep]->[0] eq 'hh'))) { | |
| 304 | push @aRep, ['mm', length($sFmtRes), 2, 'min']; | |
| 305 | } | |
| 306 | else { | |
| 307 | push @aRep, [substr($sFmtObj, $i, 2), length($sFmtRes), 2]; | |
| 308 | } | |
| 309 | if((substr($sFmtObj, $i, 2) eq 'ss') && ($#aRep>0)) { | |
| 310 | if(($aRep[$#aRep-1]->[0] eq 'm') || | |
| 311 | ($aRep[$#aRep-1]->[0] eq 'mm')) { | |
| 312 | push(@{$aRep[$#aRep-1]}, 'min'); | |
| 313 | } | |
| 314 | } | |
| 315 | $i+=2; | |
| 316 | } | |
| 317 | elsif((substr($sFmtObj, $i, 1) eq 'm') || | |
| 318 | (substr($sFmtObj, $i, 1) eq 'd') || | |
| 319 | (substr($sFmtObj, $i, 1) eq 'h') || | |
| 320 | (substr($sFmtObj, $i, 1) eq 's')){ | |
| 321 | if((substr($sFmtObj, $i, 1) eq 'm') && | |
| 322 | ($#aRep>=0) && | |
| 323 | (($aRep[$#aRep]->[0] eq 'h') or ($aRep[$#aRep]->[0] eq 'hh'))) { | |
| 324 | push @aRep, ['m', length($sFmtRes), 1, 'min']; | |
| 325 | } | |
| 326 | else { | |
| 327 | push @aRep, [substr($sFmtObj, $i, 1), length($sFmtRes), 1]; | |
| 328 | } | |
| 329 | if((substr($sFmtObj, $i, 1) eq 's') && ($#aRep>0)) { | |
| 330 | if(($aRep[$#aRep-1]->[0] eq 'm') || | |
| 331 | ($aRep[$#aRep-1]->[0] eq 'mm')) { | |
| 332 | push(@{$aRep[$#aRep-1]}, 'min'); | |
| 333 | } | |
| 334 | } | |
| 335 | $i+=1; | |
| 336 | } | |
| 337 | } | |
| 338 | elsif((substr($sFmtObj, $i, 3) eq '[h]')) { | |
| 339 | push @aRep, ['[h]', length($sFmtRes), 3]; | |
| 340 | $i+=3; | |
| 341 | } | |
| 342 | elsif((substr($sFmtObj, $i, 4) eq '[mm]')) { | |
| 343 | push @aRep, ['[mm]', length($sFmtRes), 4]; | |
| 344 | $i+=4; | |
| 345 | } | |
| 346 | elsif($sWk eq '@') { | |
| 347 | push @aRep, ['@', length($sFmtRes), 1]; | |
| 348 | $i++; | |
| 349 | } | |
| 350 | elsif($sWk eq '*') { | |
| 351 | push @aRep, [substr($sFmtObj, $i, 1), | |
| 352 | length($sFmtRes), 1]; | |
| 353 | } | |
| 354 | else{ | |
| 355 | $i++; | |
| 356 | } | |
| 357 | $i++ if($i == $iSt); #No Format match | |
| 358 | $sFmtRes .= substr($sFmtObj, $iSt, $i-$iSt); | |
| 359 | } | |
| 360 | #print "FMT: $iRpos ",$sFmtRes, "\n"; | |
| 361 | if($iFflg != -1) { | |
| 362 | push @aRep, [substr($sFmtObj, $iFflg, $i-$iFflg+1), | |
| 363 | $iRpos,, $i-$iFflg+1]; | |
| 364 | $iFflg= 0; | |
| 365 | } | |
| 366 | ||
| 367 | #For Date format | |
| 368 | $iFmtMode = 0 if(defined $sType && $sType eq 'Text'); #Not Convert Non Numeric | |
| 369 | if(($iFmtMode==2)&& ($iData =~/$sNUMEXP/)) { | |
| 370 | my @aTime = ExcelLocaltime($iData, $i1904); | |
| 371 | $aTime[4]++; | |
| 372 | $aTime[5] += 1900; | |
| 373 | ||
| 374 | my @aMonL = | |
| 375 | qw (dum January February March April May June July | |
| 376 | August September October November December ); | |
| 377 | my @aMonNm = | |
| 378 | qw (dum Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); | |
| 379 | my @aWeekNm = | |
| 380 | qw (Mon Tue Wed Thu Fri Sat Sun); | |
| 381 | my @aWeekL = | |
| 382 | qw (Monday Tuesday Wednesday Thursday Friday Saturday Sunday); | |
| 383 | my $sRep; | |
| 384 | for(my $iIt=$#aRep; $iIt>=0;$iIt--) { | |
| 385 | my $rItem = $aRep[$iIt]; | |
| 386 | if((scalar @$rItem) >=4) { | |
| 387 | #Min | |
| 388 | if($rItem->[0] eq 'mm') { | |
| 389 | $sRep = sprintf("%02d", $aTime[1]); | |
| 390 | } | |
| 391 | else { | |
| 392 | $sRep = sprintf("%d", $aTime[1]); | |
| 393 | } | |
| 394 | } | |
| 395 | #Year | |
| 396 | elsif($rItem->[0] eq 'yyyy') { | |
| 397 | $sRep = sprintf('%04d', $aTime[5]); | |
| 398 | } | |
| 399 | elsif($rItem->[0] eq 'yy') { | |
| 400 | $sRep = sprintf('%02d', $aTime[5] % 100); | |
| 401 | } | |
| 402 | #Mon | |
| 403 | elsif($rItem->[0] eq 'mmmmm') { | |
| 404 | $sRep = substr($aMonNm[$aTime[4]], 0, 1); | |
| 405 | } | |
| 406 | elsif($rItem->[0] eq 'mmmm') { | |
| 407 | $sRep = $aMonL[$aTime[4]]; | |
| 408 | } | |
| 409 | elsif($rItem->[0] eq 'mmm') { | |
| 410 | $sRep = $aMonNm[$aTime[4]]; | |
| 411 | } | |
| 412 | elsif($rItem->[0] eq 'mm') { | |
| 413 | $sRep = sprintf('%02d', $aTime[4]); | |
| 414 | } | |
| 415 | elsif($rItem->[0] eq 'm') { | |
| 416 | $sRep = sprintf('%d', $aTime[4]); | |
| 417 | } | |
| 418 | #Day | |
| 419 | elsif($rItem->[0] eq 'dddd') { | |
| 420 | $sRep = $aWeekL[$aTime[7]]; | |
| 421 | } | |
| 422 | elsif($rItem->[0] eq 'ddd') { | |
| 423 | $sRep = $aWeekNm[$aTime[7]]; | |
| 424 | } | |
| 425 | elsif($rItem->[0] eq 'dd') { | |
| 426 | $sRep = sprintf('%02d', $aTime[3]); | |
| 427 | } | |
| 428 | elsif($rItem->[0] eq 'd') { | |
| 429 | $sRep = sprintf('%d', $aTime[3]); | |
| 430 | } | |
| 431 | #Hour | |
| 432 | elsif($rItem->[0] eq 'hh') { | |
| 433 | if($iAm) { | |
| 434 | $sRep = sprintf('%02d', $aTime[2]%12); | |
| 435 | } | |
| 436 | else { | |
| 437 | $sRep = sprintf('%02d', $aTime[2]); | |
| 438 | } | |
| 439 | } | |
| 440 | elsif($rItem->[0] eq 'h') { | |
| 441 | if($iAm) { | |
| 442 | $sRep = sprintf('%d', $aTime[2]%12); | |
| 443 | } | |
| 444 | else { | |
| 445 | $sRep = sprintf('%d', $aTime[2]); | |
| 446 | } | |
| 447 | } | |
| 448 | #SS | |
| 449 | elsif($rItem->[0] eq 'ss') { | |
| 450 | $sRep = sprintf('%02d', $aTime[0]); | |
| 451 | } | |
| 452 | elsif($rItem->[0] eq 'S') { | |
| 453 | $sRep = sprintf('%d', $aTime[0]); | |
| 454 | } | |
| 455 | #am/pm | |
| 456 | elsif($rItem->[0] eq 'am/pm') { | |
| 457 | $sRep = ($aTime[4]>12)? 'pm':'am'; | |
| 458 | } | |
| 459 | elsif($rItem->[0] eq 'a/p') { | |
| 460 | $sRep = ($aTime[4]>12)? 'p':'a'; | |
| 461 | } | |
| 462 | elsif($rItem->[0] eq '.') { | |
| 463 | $sRep = '.'; | |
| 464 | } | |
| 465 | elsif($rItem->[0] =~ /^0+$/) { | |
| 466 | my $i0Len = length($&); | |
| 467 | #print "SEC:", $aTime[7], "\n"; | |
| 468 | $sRep = substr(sprintf("%.${i0Len}f", $aTime[7]/1000.0), 2, $i0Len); | |
| 469 | } | |
| 470 | elsif($rItem->[0] eq '[h]') { | |
| 471 | $sRep = sprintf('%d', int($iData) * 24 + $aTime[2]); | |
| 472 | } | |
| 473 | elsif($rItem->[0] eq '[mm]') { | |
| 474 | $sRep = sprintf('%d', (int($iData) * 24 + $aTime[2])*60 + $aTime[1]); | |
| 475 | } | |
| 476 | #NENGO(Japanese) | |
| 477 | elsif($rItem->[0] eq 'ge') { | |
| 478 | $sRep = Spreadsheet::ParseExcel::FmtJapan::CnvNengo(1, @aTime); | |
| 479 | } | |
| 480 | elsif($rItem->[0] eq 'ggge') { | |
| 481 | $sRep = Spreadsheet::ParseExcel::FmtJapan::CnvNengo(2, @aTime); | |
| 482 | } | |
| 483 | elsif($rItem->[0] eq '@') { | |
| 484 | $sRep = $iData; | |
| 485 | } | |
| 486 | ||
| 487 | #print "REP:$sRep ",$rItem->[0], ":", $rItem->[1], ":" ,$rItem->[2], "\n"; | |
| 488 | substr($sFmtRes, $rItem->[1], $rItem->[2]) = $sRep; | |
| 489 | } | |
| 490 | } | |
| 491 | elsif(($iFmtMode==1)&& ($iData =~/$sNUMEXP/)) { | |
| 492 | if($#aRep>=0) { | |
| 493 | while($aRep[$#aRep]->[0] eq ',') { | |
| 494 | $iCmmCnt--; | |
| 495 | substr($sFmtRes, $aRep[$#aRep]->[1], $aRep[$#aRep]->[2]) = ''; | |
| 496 | $iData /= 1000; | |
| 497 | pop @aRep; | |
| 498 | } | |
| 499 | ||
| 500 | my $sNumFmt = join('', map {$_->[0]} @aRep); | |
| 501 | my $sNumRes; | |
| 502 | my $iTtl=0; | |
| 503 | my $iE=0; | |
| 504 | my $iP=0; | |
| 505 | my $iInt = 0; | |
| 506 | my $iAftP=undef; | |
| 507 | foreach my $sItem (split //, $sNumFmt) { | |
| 508 | if($sItem eq '.') { | |
| 509 | $iTtl++; | |
| 510 | $iP = 1; | |
| 511 | } | |
| 512 | elsif(($sItem eq 'E') || ($sItem eq 'e')){ | |
| 513 | $iE = 1; | |
| 514 | } | |
| 515 | elsif($sItem eq '0') { | |
| 516 | $iTtl++; | |
| 517 | $iAftP++ if($iP); | |
| 518 | $iInt = 1; | |
| 519 | } | |
| 520 | elsif($sItem eq '#') { | |
| 521 | #$iTtl++; | |
| 522 | $iAftP++ if($iP); | |
| 523 | $iInt = 1; | |
| 524 | } | |
| 525 | elsif($sItem eq '?') { | |
| 526 | #$iTtl++; | |
| 527 | $iAftP++ if($iP); | |
| 528 | } | |
| 529 | } | |
| 530 | #print "DATA:$iData\n"; | |
| 531 | $iData *= 100.0 if($iPer); | |
| 532 | my $iDData = ($iFugouFlg)? abs($iData) : $iData+0; | |
| 533 | if($iBunFlg) { | |
| 534 | $sNumRes = sprintf("%0${iTtl}d", int($iDData)); | |
| 535 | } | |
| 536 | else { | |
| 537 | if($iP) { | |
| 538 | # $sNumRes = sprintf("%0${iTtl}.${iAftP}f", $iDData); | |
| 539 | $sNumRes = sprintf( | |
| 540 | (defined($iAftP)? | |
| 541 | "%0${iTtl}.${iAftP}f": "%0${iTtl}f"), $iDData); | |
| 542 | } | |
| 543 | else { | |
| 544 | #print "DATA:", $iDData, "\n"; | |
| 545 | $sNumRes = sprintf("%0${iTtl}.0f", $iDData); | |
| 546 | } | |
| 547 | } | |
| 548 | #print "sNum:$sNumRes\n"; | |
| 549 | $sNumRes = AddComma($sNumRes) if($iCmmCnt > 0); | |
| 550 | #print "RES:$sNumRes\n"; | |
| 551 | my $iLen = length($sNumRes); | |
| 552 | my $iPPos = -1; | |
| 553 | my $sRep; | |
| 554 | ||
| 555 | for(my $iIt=$#aRep; $iIt>=0;$iIt--) { | |
| 556 | my $rItem = $aRep[$iIt]; | |
| 557 | #print "Rep:", unpack("H*", $rItem->[0]), "\n"; | |
| 558 | if($rItem->[0] =~/([#0]*)([\.]?)([0#]*)([eE])([\+\-])([0#]+)/) { | |
| 559 | substr($sFmtRes, $rItem->[1], $rItem->[2]) = | |
| 560 | MakeE($rItem->[0], $iData); | |
| 561 | } | |
| 562 | elsif($rItem->[0] =~ /\//) { | |
| 563 | substr($sFmtRes, $rItem->[1], $rItem->[2]) = | |
| 564 | MakeBun($rItem->[0], $iData, $iInt); | |
| 565 | } | |
| 566 | elsif($rItem->[0] eq '.') { | |
| 567 | $iLen--; | |
| 568 | $iPPos=$iLen; | |
| 569 | } | |
| 570 | elsif($rItem->[0] eq '+') { | |
| 571 | substr($sFmtRes, $rItem->[1], $rItem->[2]) = | |
| 572 | ($iData > 0)? '+': (($iData==0)? '+':'-'); | |
| 573 | } | |
| 574 | elsif($rItem->[0] eq '-') { | |
| 575 | substr($sFmtRes, $rItem->[1], $rItem->[2]) = | |
| 576 | ($iData > 0)? '': (($iData==0)? '':'-'); | |
| 577 | } | |
| 578 | elsif($rItem->[0] eq '@') { | |
| 579 | substr($sFmtRes, $rItem->[1], $rItem->[2]) = $iData; | |
| 580 | } | |
| 581 | elsif($rItem->[0] eq '*') { | |
| 582 | substr($sFmtRes, $rItem->[1], $rItem->[2]) = ''; #REMOVE | |
| 583 | } | |
| 584 | elsif(($rItem->[0] eq "\xA2\xA4") or ($rItem->[0] eq "\xA2\xA5") or | |
| 585 | ($rItem->[0] eq "\x81\xA2") or ($rItem->[0] eq "\x81\xA3") ){ | |
| 586 | substr($sFmtRes, $rItem->[1], $rItem->[2]) = $rItem->[0]; | |
| 587 | # ($iData > 0)? '': (($iData==0)? '':$rItem->[0]); | |
| 588 | } | |
| 589 | elsif(($rItem->[0] eq '(') or ($rItem->[0] eq ')')){ | |
| 590 | substr($sFmtRes, $rItem->[1], $rItem->[2]) = $rItem->[0]; | |
| 591 | # ($iData > 0)? '': (($iData==0)? '':$rItem->[0]); | |
| 592 | } | |
| 593 | else { | |
| 594 | if($iLen>0) { | |
| 595 | if($iIt <= 0) { | |
| 596 | $sRep = substr($sNumRes, 0, $iLen); | |
| 597 | $iLen = 0; | |
| 598 | } | |
| 599 | else { | |
| 600 | my $iReal = length($rItem->[0]); | |
| 601 | if($iPPos >= 0) { | |
| 602 | my $sWkF = $rItem->[0]; | |
| 603 | $sWkF=~s/^#+//; | |
| 604 | $iReal = length($sWkF); | |
| 605 | $iReal = ($iLen <=$iReal)? $iLen:$iReal; | |
| 606 | } | |
| 607 | else { | |
| 608 | $iReal = ($iLen <=$iReal)? $iLen:$iReal; | |
| 609 | } | |
| 610 | $sRep = substr($sNumRes, $iLen - $iReal, $iReal); | |
| 611 | $iLen -=$iReal; | |
| 612 | } | |
| 613 | } | |
| 614 | else { | |
| 615 | $sRep = ''; | |
| 616 | } | |
| 617 | substr($sFmtRes, $rItem->[1], $rItem->[2]) = "\x00" . $sRep; | |
| 618 | } | |
| 619 | } | |
| 620 | $sRep = ($iLen > 0)?substr($sNumRes, 0, $iLen) : ''; | |
| 621 | $sFmtRes =~ s/\x00/$sRep/; | |
| 622 | $sFmtRes =~ s/\x00//g; | |
| 623 | } | |
| 624 | } | |
| 625 | else { | |
| 626 | my $iAtMk = 0; | |
| 627 | for(my $iIt=$#aRep; $iIt>=0;$iIt--) { | |
| 628 | my $rItem = $aRep[$iIt]; | |
| 629 | if($rItem->[0] eq '@') { | |
| 630 | substr($sFmtRes, $rItem->[1], $rItem->[2]) = $iData; | |
| 631 | $iAtMk++; | |
| 632 | } | |
| 633 | else { | |
| 634 | substr($sFmtRes, $rItem->[1], $rItem->[2]) = ''; | |
| 635 | } | |
| 636 | } | |
| 637 | $sFmtRes = $iData unless($iAtMk); | |
| 638 | } | |
| 639 | return wantarray()? ($sFmtRes, $sColor) : $sFmtRes; | |
| 640 | } | |
| 641 | #------------------------------------------------------------------------------ | |
| 642 | # AddComma (for Spreadsheet::ParseExcel::Utility) | |
| 643 | #------------------------------------------------------------------------------ | |
| 644 | sub AddComma($) { | |
| 645 | my($sNum) = @_; | |
| 646 | ||
| 647 | if($sNum=~ /^([^\d]*)(\d\d\d\d+)(\.*.*)$/) { | |
| 648 | my($sPre, $sObj, $sAft) =($1, $2, $3); | |
| 649 | for(my $i=length($sObj)-3;$i>0; $i-=3) { | |
| 650 | substr($sObj, $i, 0) = ','; | |
| 651 | } | |
| 652 | return $sPre . $sObj . $sAft; | |
| 653 | } | |
| 654 | else { | |
| 655 | return $sNum; | |
| 656 | } | |
| 657 | } | |
| 658 | #------------------------------------------------------------------------------ | |
| 659 | # MakeBun (for Spreadsheet::ParseExcel::Utility) | |
| 660 | #------------------------------------------------------------------------------ | |
| 661 | sub MakeBun($$;$) { | |
| 662 | my($sFmt, $iData, $iFlg) = @_; | |
| 663 | my $iBunbo; | |
| 664 | my $iShou; | |
| 665 | ||
| 666 | #1. Init | |
| 667 | #print "FLG: $iFlg\n"; | |
| 668 | if($iFlg) { | |
| 669 | $iShou = $iData - int($iData); | |
| 670 | return '' if($iShou == 0); | |
| 671 | } | |
| 672 | else { | |
| 673 | $iShou = $iData; | |
| 674 | } | |
| 675 | $iShou = abs($iShou); | |
| 676 | my $sSWk; | |
| 677 | ||
| 678 | #2.Calc BUNBO | |
| 679 | #2.1 BUNBO defined | |
| 680 | if($sFmt =~ /\/(\d+)$/) { | |
| 681 | $iBunbo = $1; | |
| 682 | return sprintf("%d/%d", $iShou*$iBunbo, $iBunbo); | |
| 683 | } | |
| 684 | else { | |
| 685 | #2.2 Calc BUNBO | |
| 686 | $sFmt =~ /\/(\?+)$/; | |
| 687 | my $iKeta = length($1); | |
| 688 | my $iSWk = 1; | |
| 689 | my $sSWk = ''; | |
| 690 | my $iBunsi; | |
| 691 | for(my $iBunbo = 2;$iBunbo<10**$iKeta;$iBunbo++) { | |
| 692 | $iBunsi = int($iShou*$iBunbo + 0.5); | |
| 693 | my $iCmp = abs($iShou - ($iBunsi/$iBunbo)); | |
| 694 | if($iCmp < $iSWk) { | |
| 695 | $iSWk =$iCmp; | |
| 696 | $sSWk = sprintf("%d/%d", $iBunsi, $iBunbo); | |
| 697 | last if($iSWk==0); | |
| 698 | } | |
| 699 | } | |
| 700 | return $sSWk; | |
| 701 | } | |
| 702 | } | |
| 703 | #------------------------------------------------------------------------------ | |
| 704 | # MakeE (for Spreadsheet::ParseExcel::Utility) | |
| 705 | #------------------------------------------------------------------------------ | |
| 706 | sub MakeE($$) { | |
| 707 | my($sFmt, $iData) = @_; | |
| 708 | ||
| 709 | $sFmt=~/(([#0]*)[\.]?[#0]*)([eE])([\+\-][0#]+)/; | |
| 710 | my($sKari, $iKeta, $sE, $sSisu) = ($1, length($2), $3, $4); | |
| 711 | $iKeta = 1 if($iKeta<=0); | |
| 712 | ||
| 713 | my $iLog10 = 0; | |
| 714 | $iLog10 = ($iData == 0)? 0 : (log(abs($iData))/ log(10)); | |
| 715 | $iLog10 = (int($iLog10 / $iKeta) + | |
| 716 | ((($iLog10 - int($iLog10 / $iKeta))<0)? -1: 0)) *$iKeta; | |
| 717 | ||
| 718 | my $sUe = ExcelFmt($sKari, $iData*(10**($iLog10*-1)),0); | |
| 719 | my $sShita = ExcelFmt($sSisu, $iLog10, 0); | |
| 720 | return $sUe . $sE . $sShita; | |
| 721 | } | |
| 722 | #------------------------------------------------------------------------------ | |
| 723 | # LeapYear (for Spreadsheet::ParseExcel::Utility) | |
| 724 | #------------------------------------------------------------------------------ | |
| 725 | sub LeapYear($) { | |
| 726 | my($iYear)=@_; | |
| 727 | return 1 if($iYear==1900); #Special for Excel | |
| 728 | return ((($iYear % 4)==0) && (($iYear % 100) || ($iYear % 400)==0))? 1: 0; | |
| 729 | } | |
| 730 | #------------------------------------------------------------------------------ | |
| 731 | # LocaltimeExcel (for Spreadsheet::ParseExcel::Utility) | |
| 732 | #------------------------------------------------------------------------------ | |
| 733 | sub LocaltimeExcel($$$$$$;$$) { | |
| 734 | my($iSec, $iMin, $iHour, $iDay, $iMon, $iYear, $iMSec, $flg1904) = @_; | |
| 735 | ||
| 736 | #0. Init | |
| 737 | $iMon++; | |
| 738 | $iYear+=1900; | |
| 739 | ||
| 740 | #1. Calc Time | |
| 741 | my $iTime; | |
| 742 | $iTime =$iHour; | |
| 743 | $iTime *=60; | |
| 744 | $iTime +=$iMin; | |
| 745 | $iTime *=60; | |
| 746 | $iTime +=$iSec; | |
| 747 | $iTime += $iMSec/1000.0 if(defined($iMSec)) ; | |
| 748 | $iTime /= 86400.0; #3600*24(1day in seconds) | |
| 749 | my $iY; | |
| 750 | my $iYDays; | |
| 751 | ||
| 752 | #2. Calc Days | |
| 753 | if($flg1904) { | |
| 754 | $iY = 1904; | |
| 755 | $iTime--; #Start from Jan 1st | |
| 756 | $iYDays = 366; | |
| 757 | } | |
| 758 | else { | |
| 759 | $iY = 1900; | |
| 760 | $iYDays = 366; #In Excel 1900 is leap year (That's not TRUE!) | |
| 761 | } | |
| 762 | while($iY<$iYear) { | |
| 763 | $iTime += $iYDays; | |
| 764 | $iY++; | |
| 765 | $iYDays = (LeapYear($iY))? 366: 365; | |
| 766 | } | |
| 767 | for(my $iM=1;$iM < $iMon; $iM++){ | |
| 768 | if($iM == 1 || $iM == 3 || $iM == 5 || $iM == 7 || $iM == 8 | |
| 769 | || $iM == 10 || $iM == 12) { | |
| 770 | $iTime += 31; | |
| 771 | } | |
| 772 | elsif($iM == 4 || $iM == 6 || $iM == 9 || $iM == 11) { | |
| 773 | $iTime += 30; | |
| 774 | } | |
| 775 | elsif($iM == 2) { | |
| 776 | $iTime += (LeapYear($iYear))? 29: 28; | |
| 777 | } | |
| 778 | } | |
| 779 | $iTime+=$iDay; | |
| 780 | return $iTime; | |
| 781 | } | |
| 782 | #------------------------------------------------------------------------------ | |
| 783 | # ExcelLocaltime (for Spreadsheet::ParseExcel::Utility) | |
| 784 | #------------------------------------------------------------------------------ | |
| 785 | sub ExcelLocaltime($;$) | |
| 786 | { | |
| 787 | my($dObj, $flg1904) = @_; | |
| 788 | my($iSec, $iMin, $iHour, $iDay, $iMon, $iYear, $iwDay, $iMSec); | |
| 789 | my($iDt, $iTime, $iYDays); | |
| 790 | ||
| 791 | $iDt = int($dObj); | |
| 792 | $iTime = $dObj - $iDt; | |
| 793 | ||
| 794 | #1. Calc Days | |
| 795 | if($flg1904) { | |
| 796 | $iYear = 1904; | |
| 797 | $iDt++; #Start from Jan 1st | |
| 798 | $iYDays = 366; | |
| 799 | $iwDay = (($iDt+4) % 7); | |
| 800 | } | |
| 801 | else { | |
| 802 | $iYear = 1900; | |
| 803 | $iYDays = 366; #In Excel 1900 is leap year (That's not TRUE!) | |
| 804 | $iwDay = (($iDt+6) % 7); | |
| 805 | } | |
| 806 | while($iDt > $iYDays) { | |
| 807 | $iDt -= $iYDays; | |
| 808 | $iYear++; | |
| 809 | $iYDays = ((($iYear % 4)==0) && | |
| 810 | (($iYear % 100) || ($iYear % 400)==0))? 366: 365; | |
| 811 | } | |
| 812 | $iYear -= 1900; | |
| 813 | for($iMon=1;$iMon < 12; $iMon++){ | |
| 814 | my $iMD; | |
| 815 | if($iMon == 1 || $iMon == 3 || $iMon == 5 || $iMon == 7 || $iMon == 8 | |
| 816 | || $iMon == 10 || $iMon == 12) { | |
| 817 | $iMD = 31; | |
| 818 | } | |
| 819 | elsif($iMon == 4 || $iMon == 6 || $iMon == 9 || $iMon == 11) { | |
| 820 | $iMD = 30; | |
| 821 | } | |
| 822 | elsif($iMon == 2) { | |
| 823 | $iMD = (($iYear % 4) == 0)? 29: 28; | |
| 824 | } | |
| 825 | last if($iDt <= $iMD); | |
| 826 | $iDt -= $iMD; | |
| 827 | } | |
| 828 | ||
| 829 | #2. Calc Time | |
| 830 | $iDay = $iDt; | |
| 831 | $iTime += (0.0005 / 86400.0); | |
| 832 | $iTime*=24.0; | |
| 833 | $iHour = int($iTime); | |
| 834 | $iTime -= $iHour; | |
| 835 | $iTime *= 60.0; | |
| 836 | $iMin = int($iTime); | |
| 837 | $iTime -= $iMin; | |
| 838 | $iTime *= 60.0; | |
| 839 | $iSec = int($iTime); | |
| 840 | $iTime -= $iSec; | |
| 841 | $iTime *= 1000.0; | |
| 842 | $iMSec = int($iTime); | |
| 843 | ||
| 844 | return ($iSec, $iMin, $iHour, $iDay, $iMon-1, $iYear, $iwDay, $iMSec); | |
| 845 | } | |
| 846 | # ----------------------------------------------------------------------------- | |
| 847 | # col2int (for Spreadsheet::ParseExcel::Utility) | |
| 848 | #------------------------------------------------------------------------------ | |
| 849 | # converts a excel row letter into an int for use in an array | |
| 850 | sub col2int { | |
| 851 | my $result = 0 ; | |
| 852 | my $str = shift ; | |
| 853 | my $incr = 0 ; | |
| 854 | ||
| 855 | for(my $i = length($str) ; $i > 0 ; $i--) { | |
| 856 | my $char = substr( $str, $i-1) ; | |
| 857 | my $curr += ord(lc($char)) - ord('a') + 1; | |
| 858 | $curr *= $incr if( $incr) ; | |
| 859 | $result += $curr ; | |
| 860 | $incr += 26 ; | |
| 861 | } | |
| 862 | # this is one out as we range 0..x-1 not 1..x | |
| 863 | $result-- ; | |
| 864 | ||
| 865 | return $result ; | |
| 866 | } | |
| 867 | # ----------------------------------------------------------------------------- | |
| 868 | # int2col (for Spreadsheet::ParseExcel::Utility) | |
| 869 | #------------------------------------------------------------------------------ | |
| 870 | ### int2col | |
| 871 | # convert a column number into column letters | |
| 872 | # @note this is quite a brute force coarse method | |
| 873 | # does not manage values over 701 (ZZ) | |
| 874 | # @arg number, to convert | |
| 875 | # @returns string, column name | |
| 876 | # | |
| 877 | sub int2col { | |
| 878 | my $out = "" ; | |
| 879 | my $val = shift ; | |
| 880 | ||
| 881 | do { | |
| 882 | $out .= chr(( $val % 26) + ord('A')) ; | |
| 883 | $val = int( $val / 26) - 1 ; | |
| 884 | } while( $val >= 0) ; | |
| 885 | ||
| 886 | return reverse $out ; | |
| 887 | } | |
| 888 | # ----------------------------------------------------------------------------- | |
| 889 | # sheetRef (for Spreadsheet::ParseExcel::Utility) | |
| 890 | #------------------------------------------------------------------------------ | |
| 891 | # ----------------------------------------------------------------------------- | |
| 892 | ### sheetRef | |
| 893 | # convert an excel letter-number address into a useful array address | |
| 894 | # @note that also Excel uses X-Y notation, we normally use Y-X in arrays | |
| 895 | # @args $str, excel coord eg. A2 | |
| 896 | # @returns an array - 2 elements - column, row, or undefined | |
| 897 | # | |
| 898 | sub sheetRef { | |
| 899 | my $str = shift ; | |
| 900 | my @ret ; | |
| 901 | ||
| 902 | $str =~ m/^(\D+)(\d+)$/ ; | |
| 903 | ||
| 904 | if( $1 && $2) { | |
| 905 | push( @ret, $2 -1, col2int($1)) ; | |
| 906 | } | |
| 907 | if( $ret[0] < 0) { | |
| 908 | undef @ret ; | |
| 909 | } | |
| 910 | ||
| 911 | return @ret ; | |
| 912 | } | |
| 913 | # ----------------------------------------------------------------------------- | |
| 914 | # xls2csv (for Spreadsheet::ParseExcel::Utility) | |
| 915 | #------------------------------------------------------------------------------ | |
| 916 | ### xls2csv | |
| 917 | # convert a chunk of an excel file into csv text chunk | |
| 918 | # @args $param, sheet-colrow:colrow (1-A1:B2 or A1:B2 for sheet 1 | |
| 919 | # @args $rotate, 0 or 1 decides if output should be rotated or not | |
| 920 | # @returns string containing a chunk of csv | |
| 921 | # | |
| 922 | sub xls2csv { | |
| 923 | my ($filename, $regions, $rotate) = @_ ; | |
| 924 | my $sheet = 0 ; | |
| 925 | my $output = "" ; | |
| 926 | ||
| 927 | # extract any sheet number from the region string | |
| 928 | $regions =~ m/^(\d+)-(.*)/ ; | |
| 929 | ||
| 930 | if( $2) { | |
| 931 | $sheet = $1 - 1 ; | |
| 932 | $regions = $2 ; | |
| 933 | } | |
| 934 | ||
| 935 | # now extract the start and end regions | |
| 936 | $regions =~ m/(.*):(.*)/ ; | |
| 937 | ||
| 938 | if( !$1 || !$2) { | |
| 939 | print STDERR "Bad Params"; | |
| 940 | return "" ; | |
| 941 | } | |
| 942 | ||
| 943 | my @start = sheetRef( $1) ; | |
| 944 | my @end = sheetRef( $2) ; | |
| 945 | if( !@start) { | |
| 946 | print STDERR "Bad coorinates - $1"; | |
| 947 | return "" ; | |
| 948 | } | |
| 949 | if( !@end) { | |
| 950 | print STDERR "Bad coorinates - $2"; | |
| 951 | return "" ; | |
| 952 | } | |
| 953 | ||
| 954 | if( $start[1] > $end[1]) { | |
| 955 | print STDERR "Bad COLUMN ordering\n"; | |
| 956 | print STDERR "Start column " . int2col($start[1]); | |
| 957 | print STDERR " after end column " . int2col($end[1]) . "\n"; | |
| 958 | return "" ; | |
| 959 | } | |
| 960 | if( $start[0] > $end[0]) { | |
| 961 | print STDERR "Bad ROW ordering\n"; | |
| 962 | print STDERR "Start row " . ($start[0] + 1); | |
| 963 | print STDERR " after end row " . ($end[0] + 1) . "\n"; | |
| 964 | exit ; | |
| 965 | } | |
| 966 | ||
| 967 | # start the excel object now | |
| 968 | my $oExcel = new Spreadsheet::ParseExcel ; | |
| 969 | my $oBook = $oExcel->Parse( $filename) ; | |
| 970 | # open the sheet | |
| 971 | my $oWkS = $oBook->{Worksheet}[ $sheet] ; | |
| 972 | ||
| 973 | # now check that the region exists in the file | |
| 974 | # if not trucate to the possible region | |
| 975 | # output a warning msg | |
| 976 | if( $start[1] < $oWkS->{MinCol}) { | |
| 977 | print STDERR int2col( $start[1]) . " < min col " . int2col( $oWkS->{MinCol}) . " Reseting\n"; | |
| 978 | $start[1] = $oWkS->{MinCol} ; | |
| 979 | } | |
| 980 | if( $end[1] > $oWkS->{MaxCol}) { | |
| 981 | print STDERR int2col( $end[1]) . " > max col " . int2col( $oWkS->{MaxCol}) . " Reseting\n" ; | |
| 982 | $end[1] = $oWkS->{MaxCol} ; | |
| 983 | } | |
| 984 | if( $start[0] < $oWkS->{MinRow}) { | |
| 985 | print STDERR "" . ($start[0] + 1) . " < min row " . ($oWkS->{MinRow} + 1) . " Reseting\n"; | |
| 986 | $start[0] = $oWkS->{MinCol} ; | |
| 987 | } | |
| 988 | if( $end[0] > $oWkS->{MaxRow}) { | |
| 989 | print STDERR "" . ($end[0] + 1) . " > max row " . ($oWkS->{MaxRow} + 1) . " Reseting\n"; | |
| 990 | $end[0] = $oWkS->{MaxRow} ; | |
| 991 | ||
| 992 | } | |
| 993 | ||
| 994 | my $x1 = $start[1] ; | |
| 995 | my $y1 = $start[0] ; | |
| 996 | my $x2 = $end[1] ; | |
| 997 | my $y2 = $end[0] ; | |
| 998 | ||
| 999 | if( !$rotate) { | |
| 1000 | for( my $y = $y1 ; $y <= $y2 ; $y++) { | |
| 1001 | for( my $x = $x1 ; $x <= $x2 ; $x++) { | |
| 1002 | my $cell = $oWkS->{Cells}[$y][$x] ; | |
| 1003 | $output .= $cell->Value if(defined $cell); | |
| 1004 | $output .= "," if( $x != $x2) ; | |
| 1005 | } | |
| 1006 | $output .= "\n" ; | |
| 1007 | } | |
| 1008 | } else { | |
| 1009 | for( my $x = $x1 ; $x <= $x2 ; $x++) { | |
| 1010 | for( my $y = $y1 ; $y <= $y2 ; $y++) { | |
| 1011 | my $cell = $oWkS->{Cells}[$y][$x] ; | |
| 1012 | $output .= $cell->Value if(defined $cell); | |
| 1013 | $output .= "," if( $y != $y2) ; | |
| 1014 | } | |
| 1015 | $output .= "\n" ; | |
| 1016 | } | |
| 1017 | } | |
| 1018 | ||
| 1019 | return $output ; | |
| 1020 | } | |
| 1021 | ||
| 1022 | 1; | |
| 1023 | __END__ | |
| 1024 | ||
| 1025 | =head1 NAME | |
| 1026 | ||
| 1027 | Spreadsheet::ParseExcel::Utility - Utility function for Spreadsheet::ParseExcel | |
| 1028 | ||
| 1029 | =head1 SYNOPSIS | |
| 1030 | ||
| 1031 | use strict; | |
| 1032 | #Declare | |
| 1033 | use Spreadsheet::ParseExcel::Utility qw(ExcelFmt ExcelLocaltime LocaltimeExcel); | |
| 1034 | ||
| 1035 | #Convert localtime ->Excel Time | |
| 1036 | my $iBirth = LocaltimeExcel(11, 10, 12, 23, 2, 64); | |
| 1037 | # = 1964-3-23 12:10:11 | |
| 1038 | print $iBirth, "\n"; # 23459.5070717593 | |
| 1039 | ||
| 1040 | #Convert Excel Time -> localtime | |
| 1041 | my @aBirth = ExcelLocaltime($iBirth, undef); | |
| 1042 | print join(":", @aBirth), "\n"; # 11:10:12:23:2:64:1:0 | |
| 1043 | ||
| 1044 | #Formatting | |
| 1045 | print ExcelFmt('yyyy-mm-dd', $iBirth), "\n"; #1964-3-23 | |
| 1046 | print ExcelFmt('m-d-yy', $iBirth), "\n"; # 3-23-64 | |
| 1047 | print ExcelFmt('#,##0', $iBirth), "\n"; # 23,460 | |
| 1048 | print ExcelFmt('#,##0.00', $iBirth), "\n"; # 23,459.51 | |
| 1049 | print ExcelFmt('"My Birthday is (m/d):" m/d', $iBirth), "\n"; | |
| 1050 | # My Birthday is (m/d): 3/23 | |
| 1051 | ||
| 1052 | =head1 DESCRIPTION | |
| 1053 | ||
| 1054 | Spreadsheet::ParseExcel::Utility exports utility functions concerned with Excel format setting. | |
| 1055 | ||
| 1056 | =head1 Functions | |
| 1057 | ||
| 1058 | This module can export 3 functions: ExcelFmt, ExcelLocaltime and LocaltimeExcel. | |
| 1059 | ||
| 1060 | =head2 ExcelFmt | |
| 1061 | ||
| 1062 | $sTxt = ExcelFmt($sFmt, $iData [, $i1904]); | |
| 1063 | ||
| 1064 | I<$sFmt> is a format string for Excel. I<$iData> is the target value. | |
| 1065 | If I<$flg1904> is true, this functions assumes that epoch is 1904. | |
| 1066 | I<$sTxt> is the result. | |
| 1067 | ||
| 1068 | For more detail and examples, please refer sample/chkFmt.pl in this distribution. | |
| 1069 | ||
| 1070 | ex. | |
| 1071 | ||
| 1072 | =head2 ExcelLocaltime | |
| 1073 | ||
| 1074 | ($iSec, $iMin, $iHour, $iDay, $iMon, $iYear, $iwDay, $iMSec) = | |
| 1075 | ExcelLocaltime($iExTime [, $flg1904]); | |
| 1076 | ||
| 1077 | I<ExcelLocaltime> converts time information in Excel format into Perl localtime format. | |
| 1078 | I<$iExTime> is a time of Excel. If I<$flg1904> is true, this functions assumes that | |
| 1079 | epoch is 1904. | |
| 1080 | I<$iSec>, I<$iMin>, I<$iHour>, I<$iDay>, I<$iMon>, I<$iYear>, I<$iwDay> are same as localtime. | |
| 1081 | I<$iMSec> means 1/1,000,000 seconds(ms). | |
| 1082 | ||
| 1083 | ||
| 1084 | =head2 LocaltimeExcel | |
| 1085 | ||
| 1086 | I<$iExTime> = LocaltimeExcel($iSec, $iMin, $iHour, $iDay, $iMon, $iYear [,$iMSec] [,$flg1904]) | |
| 1087 | ||
| 1088 | I<LocaltimeExcel> converts time information in Perl localtime format into Excel format . | |
| 1089 | I<$iSec>, I<$iMin>, I<$iHour>, I<$iDay>, I<$iMon>, I<$iYear> are same as localtime. | |
| 1090 | ||
| 1091 | If I<$flg1904> is true, this functions assumes that epoch is 1904. | |
| 1092 | I<$iExTime> is a time of Excel. | |
| 1093 | ||
| 1094 | =head2 col2int | |
| 1095 | ||
| 1096 | I<$iInt> = col2int($sCol); | |
| 1097 | ||
| 1098 | converts a excel row letter into an int for use in an array | |
| 1099 | ||
| 1100 | This function was contributed by Kevin Mulholland. | |
| 1101 | ||
| 1102 | =head2 int2col | |
| 1103 | ||
| 1104 | I<$sCol> = int2col($iRow); | |
| 1105 | ||
| 1106 | convert a column number into column letters | |
| 1107 | NOET: This is quite a brute force coarse method does not manage values over 701 (ZZ) | |
| 1108 | ||
| 1109 | This function was contributed by Kevin Mulholland. | |
| 1110 | ||
| 1111 | =head2 sheetRef | |
| 1112 | ||
| 1113 | (I<$iRow>, I<$iCol>) = sheetRef($sStr); | |
| 1114 | ||
| 1115 | convert an excel letter-number address into a useful array address | |
| 1116 | NOTE: That also Excel uses X-Y notation, we normally use Y-X in arrays | |
| 1117 | $sStr, excel coord (eg. A2). | |
| 1118 | ||
| 1119 | This function was contributed by Kevin Mulholland. | |
| 1120 | ||
| 1121 | =head2 xls2csv | |
| 1122 | ||
| 1123 | $sCsvTxt = xls2csv($sFileName, $sRegion, $iRotate); | |
| 1124 | ||
| 1125 | convert a chunk of an excel file into csv text chunk | |
| 1126 | $sRegions = "sheet-colrow:colrow" (ex. '1-A1:B2' means 'A1:B2' for sheet 1) | |
| 1127 | $iRotate = 0 or 1 (output should be rotated or not) | |
| 1128 | ||
| 1129 | This function was contributed by Kevin Mulholland. | |
| 1130 | ||
| 1131 | =head1 AUTHOR | |
| 1132 | ||
| 1133 | Kawai Takanori (Hippo2000) kwitknr@cpan.org | |
| 1134 | ||
| 1135 | http://member.nifty.ne.jp/hippo2000/ (Japanese) | |
| 1136 | http://member.nifty.ne.jp/hippo2000/index_e.htm (English) | |
| 1137 | ||
| 1138 | =head1 SEE ALSO | |
| 1139 | ||
| 1140 | Spreadsheet::ParseExcel, Spreadsheet::WriteExcel | |
| 1141 | ||
| 1142 | =head1 COPYRIGHT | |
| 1143 | ||
| 1144 | This module is part of the Spreadsheet::ParseExcel distribution. | |
| 1145 | ||
| 1146 | =cut |
| 0 | # Spreadsheet::ParseExcel | |
| 1 | # by Kawai, Takanori (Hippo2000) 2000.10.2 | |
| 2 | # 2001. 2.2 (Ver. 0.15) | |
| 3 | # This Program is ALPHA version. | |
| 4 | #////////////////////////////////////////////////////////////////////////////// | |
| 5 | # Spreadsheet::ParseExcel Objects | |
| 6 | #////////////////////////////////////////////////////////////////////////////// | |
| 7 | use Spreadsheet::ParseExcel::FmtDefault; | |
| 8 | #============================================================================== | |
| 9 | # Spreadsheet::ParseExcel::Workbook | |
| 10 | #============================================================================== | |
| 11 | package Spreadsheet::ParseExcel::Workbook; | |
| 12 | require Exporter; | |
| 13 | use strict; | |
| 14 | use vars qw($VERSION @ISA); | |
| 15 | @ISA = qw(Exporter); | |
| 16 | sub new($) { | |
| 17 | my ($sClass) = @_; | |
| 18 | my $oThis = {}; | |
| 19 | bless $oThis, $sClass; | |
| 20 | } | |
| 21 | #------------------------------------------------------------------------------ | |
| 22 | # Spreadsheet::ParseExcel::Workbook->ParseAbort | |
| 23 | #------------------------------------------------------------------------------ | |
| 24 | sub ParseAbort($$) { | |
| 25 | my($oThis, $sVal) =@_; | |
| 26 | $oThis->{_ParseAbort} = $sVal; | |
| 27 | } | |
| 28 | #------------------------------------------------------------------------------ | |
| 29 | # Spreadsheet::ParseExcel::Workbook->Parse | |
| 30 | #------------------------------------------------------------------------------ | |
| 31 | sub Parse($$;$) { | |
| 32 | my($sClass, $sFile, $oFmt) =@_; | |
| 33 | my $_oEx = new Spreadsheet::ParseExcel; | |
| 34 | my $oBook = $_oEx->Parse($sFile, $oFmt); | |
| 35 | $oBook->{_Excel} = $_oEx; | |
| 36 | $oBook; | |
| 37 | } | |
| 38 | #------------------------------------------------------------------------------ | |
| 39 | # Spreadsheet::ParseExcel::Workbook Worksheet | |
| 40 | #------------------------------------------------------------------------------ | |
| 41 | sub Worksheet($$) { | |
| 42 | my($oBook, $sName) =@_; | |
| 43 | my $oWkS; | |
| 44 | foreach $oWkS (@{$oBook->{Worksheet}}) { | |
| 45 | return $oWkS if($oWkS->{Name} eq $sName); | |
| 46 | } | |
| 47 | if($sName =~ /^\d+$/) { | |
| 48 | return $oBook->{Worksheet}->[$sName]; | |
| 49 | } | |
| 50 | return undef; | |
| 51 | } | |
| 52 | #============================================================================== | |
| 53 | # Spreadsheet::ParseExcel::Worksheet | |
| 54 | #============================================================================== | |
| 55 | package Spreadsheet::ParseExcel::Worksheet; | |
| 56 | require Exporter; | |
| 57 | use strict; | |
| 58 | sub sheetNo($); | |
| 59 | use overload | |
| 60 | '0+' => \&sheetNo, | |
| 61 | 'fallback' => 1, | |
| 62 | ; | |
| 63 | use vars qw($VERSION @ISA); | |
| 64 | @ISA = qw(Exporter); | |
| 65 | sub new($%) { | |
| 66 | my ($sClass, %rhIni) = @_; | |
| 67 | my $oThis = \%rhIni; | |
| 68 | ||
| 69 | $oThis->{Cells}=undef; | |
| 70 | $oThis->{DefColWidth}=8.38; | |
| 71 | bless $oThis, $sClass; | |
| 72 | } | |
| 73 | #------------------------------------------------------------------------------ | |
| 74 | # Spreadsheet::ParseExcel::Worksheet->sheetNo | |
| 75 | #------------------------------------------------------------------------------ | |
| 76 | sub sheetNo($){ | |
| 77 | my($oSelf) = @_; | |
| 78 | return $oSelf->{_SheetNo}; | |
| 79 | } | |
| 80 | #------------------------------------------------------------------------------ | |
| 81 | # Spreadsheet::ParseExcel::Worksheet->Cell | |
| 82 | #------------------------------------------------------------------------------ | |
| 83 | sub Cell($$$){ | |
| 84 | my($oSelf, $iR, $iC) = @_; | |
| 85 | ||
| 86 | # return undef if no arguments are given or if no cells are defined | |
| 87 | return if ((!defined($iR)) || (!defined($iC)) || | |
| 88 | (!defined($oSelf->{MaxRow})) || (!defined($oSelf->{MaxCol}))); | |
| 89 | ||
| 90 | # return undef if outside defined rectangle | |
| 91 | return if (($iR < $oSelf->{MinRow}) || ($iR > $oSelf->{MaxRow}) || | |
| 92 | ($iC < $oSelf->{MinCol}) || ($iC > $oSelf->{MaxCol})); | |
| 93 | ||
| 94 | # return the Cell object | |
| 95 | return $oSelf->{Cells}[$iR][$iC]; | |
| 96 | } | |
| 97 | #------------------------------------------------------------------------------ | |
| 98 | # Spreadsheet::ParseExcel::Worksheet->RowRange | |
| 99 | #------------------------------------------------------------------------------ | |
| 100 | sub RowRange($){ | |
| 101 | my($oSelf) = @_; | |
| 102 | my $iMin = $oSelf->{MinRow} || 0; | |
| 103 | my $iMax = defined($oSelf->{MaxRow}) ? $oSelf->{MaxRow} : ($iMin-1); | |
| 104 | ||
| 105 | # return the range | |
| 106 | return($iMin, $iMax); | |
| 107 | } | |
| 108 | #------------------------------------------------------------------------------ | |
| 109 | # Spreadsheet::ParseExcel::Worksheet->ColRange | |
| 110 | #------------------------------------------------------------------------------ | |
| 111 | sub ColRange($){ | |
| 112 | my($oSelf) = @_; | |
| 113 | my $iMin = $oSelf->{MinCol} || 0; | |
| 114 | my $iMax = defined($oSelf->{MaxCol}) ? $oSelf->{MaxCol} : ($iMin-1); | |
| 115 | ||
| 116 | # return the range | |
| 117 | return($iMin, $iMax); | |
| 118 | } | |
| 119 | ||
| 120 | #============================================================================== | |
| 121 | # Spreadsheet::ParseExcel::Font | |
| 122 | #============================================================================== | |
| 123 | package Spreadsheet::ParseExcel::Font; | |
| 124 | require Exporter; | |
| 125 | use strict; | |
| 126 | use vars qw($VERSION @ISA); | |
| 127 | @ISA = qw(Exporter); | |
| 128 | sub new($%) { | |
| 129 | my($sClass, %rhIni) = @_; | |
| 130 | my $oThis = \%rhIni; | |
| 131 | ||
| 132 | bless $oThis, $sClass; | |
| 133 | } | |
| 134 | #============================================================================== | |
| 135 | # Spreadsheet::ParseExcel::Format | |
| 136 | #============================================================================== | |
| 137 | package Spreadsheet::ParseExcel::Format; | |
| 138 | require Exporter; | |
| 139 | use strict; | |
| 140 | use vars qw($VERSION @ISA); | |
| 141 | @ISA = qw(Exporter); | |
| 142 | sub new($%) { | |
| 143 | my($sClass, %rhIni) = @_; | |
| 144 | my $oThis = \%rhIni; | |
| 145 | ||
| 146 | bless $oThis, $sClass; | |
| 147 | } | |
| 148 | #============================================================================== | |
| 149 | # Spreadsheet::ParseExcel::Cell | |
| 150 | #============================================================================== | |
| 151 | package Spreadsheet::ParseExcel::Cell; | |
| 152 | require Exporter; | |
| 153 | use strict; | |
| 154 | use vars qw($VERSION @ISA); | |
| 155 | @ISA = qw(Exporter); | |
| 156 | ||
| 157 | sub new($%) { | |
| 158 | my($sPkg, %rhKey)=@_; | |
| 159 | my($sWk, $iLen); | |
| 160 | my $oThis = \%rhKey; | |
| 161 | ||
| 162 | bless $oThis, $sPkg; | |
| 163 | } | |
| 164 | ||
| 165 | sub Value($){ | |
| 166 | my($oThis)=@_; | |
| 167 | return $oThis->{_Value}; | |
| 168 | } | |
| 169 | #============================================================================== | |
| 170 | # Spreadsheet::ParseExcel | |
| 171 | #============================================================================== | |
| 172 | package Spreadsheet::ParseExcel; | |
| 173 | require Exporter; | |
| 174 | use strict; | |
| 175 | use OLE::Storage_Lite; | |
| 176 | use vars qw($VERSION @ISA); | |
| 177 | @ISA = qw(Exporter); | |
| 178 | $VERSION = '0.2602'; # | |
| 179 | my @aColor = | |
| 180 | ( | |
| 181 | '000000', # 0x00 | |
| 182 | 'FFFFFF', 'FFFFFF', 'FFFFFF', 'FFFFFF', | |
| 183 | 'FFFFFF', 'FFFFFF', 'FFFFFF', 'FFFFFF', #0x08 - This one's Black, too ??? | |
| 184 | 'FFFFFF', 'FF0000', '00FF00', '0000FF', | |
| 185 | 'FFFF00', 'FF00FF', '00FFFF', '800000', # 0x10 | |
| 186 | '008000', '000080', '808000', '800080', | |
| 187 | '008080', 'C0C0C0', '808080', '9999FF', # 0x18 | |
| 188 | '993366', 'FFFFCC', 'CCFFFF', '660066', | |
| 189 | 'FF8080', '0066CC', 'CCCCFF', '000080', # 0x20 | |
| 190 | 'FF00FF', 'FFFF00', '00FFFF', '800080', | |
| 191 | '800000', '008080', '0000FF', '00CCFF', # 0x28 | |
| 192 | 'CCFFFF', 'CCFFCC', 'FFFF99', '99CCFF', | |
| 193 | 'FF99CC', 'CC99FF', 'FFCC99', '3366FF', # 0x30 | |
| 194 | '33CCCC', '99CC00', 'FFCC00', 'FF9900', | |
| 195 | 'FF6600', '666699', '969696', '003366', # 0x38 | |
| 196 | '339966', '003300', '333300', '993300', | |
| 197 | '993366', '333399', '333333', 'FFFFFF' # 0x40 | |
| 198 | ); | |
| 199 | use constant verExcel95 => 0x500; | |
| 200 | use constant verExcel97 =>0x600; | |
| 201 | use constant verBIFF2 =>0x00; | |
| 202 | use constant verBIFF3 =>0x02; | |
| 203 | use constant verBIFF4 =>0x04; | |
| 204 | use constant verBIFF5 =>0x08; | |
| 205 | use constant verBIFF8 =>0x18; #Added (Not in BOOK) | |
| 206 | ||
| 207 | my %ProcTbl =( | |
| 208 | #Develpers' Kit P291 | |
| 209 | 0x14 => \&_subHeader, # Header | |
| 210 | 0x15 => \&_subFooter, # Footer | |
| 211 | 0x18 => \&_subName, # NAME(?) | |
| 212 | 0x1A => \&_subVPageBreak, # Veritical Page Break | |
| 213 | 0x1B => \&_subHPageBreak, # Horizontal Page Break | |
| 214 | 0x22 => \&_subFlg1904, # 1904 Flag | |
| 215 | 0x26 => \&_subMergin, # Left Mergin | |
| 216 | 0x27 => \&_subMergin, # Right Mergin | |
| 217 | 0x28 => \&_subMergin, # Top Mergin | |
| 218 | 0x29 => \&_subMergin, # Bottom Mergin | |
| 219 | 0x2A => \&_subPrintHeaders, # Print Headers | |
| 220 | 0x2B => \&_subPrintGridlines, # Print Gridlines | |
| 221 | 0x3C => \&_subContinue, # Continue | |
| 222 | 0x43 => \&_subXF, # ExTended Format(?) | |
| 223 | #Develpers' Kit P292 | |
| 224 | 0x55 =>\&_subDefColWidth, # Consider | |
| 225 | 0x5C => \&_subWriteAccess, # WRITEACCESS | |
| 226 | 0x7D => \&_subColInfo, # Colinfo | |
| 227 | 0x7E => \&_subRK, # RK | |
| 228 | 0x81 => \&_subWSBOOL, # WSBOOL | |
| 229 | 0x83 => \&_subHcenter, # HCENTER | |
| 230 | 0x84 => \&_subVcenter, # VCENTER | |
| 231 | 0x85 => \&_subBoundSheet, # BoundSheet | |
| 232 | ||
| 233 | 0x92 => \&_subPalette, # Palette, fgp | |
| 234 | ||
| 235 | 0x99 => \&_subStandardWidth, # Standard Col | |
| 236 | #Develpers' Kit P293 | |
| 237 | 0xA1 => \&_subSETUP, # SETUP | |
| 238 | 0xBD => \&_subMulRK, # MULRK | |
| 239 | 0xBE => \&_subMulBlank, # MULBLANK | |
| 240 | 0xD6 => \&_subRString, # RString | |
| 241 | #Develpers' Kit P294 | |
| 242 | 0xE0 => \&_subXF, # ExTended Format | |
| 243 | 0xE5 => \&_subMergeArea, # MergeArea (Not Documented) | |
| 244 | 0xFC => \&_subSST, # Shared String Table | |
| 245 | 0xFD => \&_subLabelSST, # Label SST | |
| 246 | #Develpers' Kit P295 | |
| 247 | 0x201 => \&_subBlank, # Blank | |
| 248 | ||
| 249 | 0x202 => \&_subInteger, # Integer(Not Documented) | |
| 250 | 0x203 => \&_subNumber, # Number | |
| 251 | 0x204 => \&_subLabel , # Label | |
| 252 | 0x205 => \&_subBoolErr, # BoolErr | |
| 253 | 0x207 => \&_subString, # STRING | |
| 254 | 0x208 => \&_subRow, # RowData | |
| 255 | 0x221 => \&_subArray, #Array (Consider) | |
| 256 | 0x225 => \&_subDefaultRowHeight, # Consider | |
| 257 | ||
| 258 | ||
| 259 | 0x31 => \&_subFont, # Font | |
| 260 | 0x231 => \&_subFont, # Font | |
| 261 | ||
| 262 | 0x27E => \&_subRK, # RK | |
| 263 | 0x41E => \&_subFormat, # Format | |
| 264 | ||
| 265 | 0x06 => \&_subFormula, # Formula | |
| 266 | 0x406 => \&_subFormula, # Formula | |
| 267 | ||
| 268 | 0x09 => \&_subBOF, # BOF(BIFF2) | |
| 269 | 0x209 => \&_subBOF, # BOF(BIFF3) | |
| 270 | 0x409 => \&_subBOF, # BOF(BIFF4) | |
| 271 | 0x809 => \&_subBOF, # BOF(BIFF5-8) | |
| 272 | ); | |
| 273 | ||
| 274 | my $BIGENDIAN; | |
| 275 | my $PREFUNC; | |
| 276 | my $_CellHandler; | |
| 277 | my $_NotSetCell; | |
| 278 | my $_Object; | |
| 279 | #------------------------------------------------------------------------------ | |
| 280 | # Spreadsheet::ParseExcel->new | |
| 281 | #------------------------------------------------------------------------------ | |
| 282 | sub new($;%) { | |
| 283 | my ($sPkg, %hParam) =@_; | |
| 284 | ||
| 285 | #0. Check ENDIAN(Little: Interl etc. BIG: Sparc etc) | |
| 286 | $BIGENDIAN = (defined $hParam{Endian})? $hParam{Endian} : | |
| 287 | (unpack("H08", pack("L", 2)) eq '02000000')? 0: 1; | |
| 288 | my $oThis = {}; | |
| 289 | bless $oThis, $sPkg; | |
| 290 | ||
| 291 | #1. Set Parameter | |
| 292 | #1.1 Get Content | |
| 293 | $oThis->{GetContent} = \&_subGetContent; | |
| 294 | ||
| 295 | #1.2 Set Event Handler | |
| 296 | if($hParam{EventHandlers}) { | |
| 297 | $oThis->SetEventHandlers($hParam{EventHandlers}); | |
| 298 | } | |
| 299 | else { | |
| 300 | $oThis->SetEventHandlers(\%ProcTbl); | |
| 301 | } | |
| 302 | if($hParam{AddHandlers}) { | |
| 303 | foreach my $sKey (keys(%{$hParam{AddHandlers}})) { | |
| 304 | $oThis->SetEventHandler($sKey, $hParam{AddHandlers}->{$sKey}); | |
| 305 | } | |
| 306 | } | |
| 307 | #Experimental | |
| 308 | $_CellHandler = $hParam{CellHandler} if($hParam{CellHandler}); | |
| 309 | $_NotSetCell = $hParam{NotSetCell}; | |
| 310 | $_Object = $hParam{Object}; | |
| 311 | ||
| 312 | return $oThis; | |
| 313 | } | |
| 314 | #------------------------------------------------------------------------------ | |
| 315 | # Spreadsheet::ParseExcel->SetEventHandler | |
| 316 | #------------------------------------------------------------------------------ | |
| 317 | sub SetEventHandler($$\&) { | |
| 318 | my($oThis, $sKey, $oFunc) = @_; | |
| 319 | $oThis->{FuncTbl}->{$sKey} = $oFunc; | |
| 320 | } | |
| 321 | #------------------------------------------------------------------------------ | |
| 322 | # Spreadsheet::ParseExcel->SetEventHandlers | |
| 323 | #------------------------------------------------------------------------------ | |
| 324 | sub SetEventHandlers($$) { | |
| 325 | my($oThis, $rhTbl) = @_; | |
| 326 | $oThis->{FuncTbl} = undef; | |
| 327 | foreach my $sKey (keys %$rhTbl) { | |
| 328 | $oThis->{FuncTbl}->{$sKey} = $rhTbl->{$sKey}; | |
| 329 | } | |
| 330 | } | |
| 331 | #------------------------------------------------------------------------------ | |
| 332 | # Spreadsheet::ParseExcel->Parse | |
| 333 | #------------------------------------------------------------------------------ | |
| 334 | sub Parse($$;$) { | |
| 335 | my($oThis, $sFile, $oWkFmt)=@_; | |
| 336 | my($sWk, $bLen); | |
| 337 | ||
| 338 | #0. New $oBook | |
| 339 | my $oBook = Spreadsheet::ParseExcel::Workbook->new; | |
| 340 | $oBook->{SheetCount} = 0; | |
| 341 | ||
| 342 | #1.Get content | |
| 343 | my($sBIFF, $iLen); | |
| 344 | if(ref($sFile) eq "SCALAR") { | |
| 345 | #1.1 Specified by Buffer | |
| 346 | $sBIFF = $$sFile; | |
| 347 | $iLen = length($sBIFF); | |
| 348 | } | |
| 349 | #1.2 Specified by Other Things(HASH reference etc) | |
| 350 | # elsif(ref($sFile)) { | |
| 351 | # return undef; | |
| 352 | # } | |
| 353 | #1.2 Specified by GLOB reference | |
| 354 | elsif((ref($sFile) =~ /GLOB/) or | |
| 355 | (ref($sFile) eq 'Fh')) { #For CGI.pm (Light FileHandle) | |
| 356 | binmode($sFile); | |
| 357 | my $sWk; | |
| 358 | my $sBuff=''; | |
| 359 | while(read($sFile, $sWk, 4096)) { | |
| 360 | $sBuff .= $sWk; | |
| 361 | } | |
| 362 | ($sBIFF, $iLen) = $oThis->{GetContent}->(\$sBuff); | |
| 363 | return undef unless($sBIFF); | |
| 364 | } | |
| 365 | elsif(ref($sFile) eq 'ARRAY') { | |
| 366 | #1.3 Specified by File content | |
| 367 | $oBook->{File} = undef; | |
| 368 | my $sData = join('', @$sFile); | |
| 369 | ($sBIFF, $iLen) = $oThis->{GetContent}->(\$sData); | |
| 370 | return undef unless($sBIFF); | |
| 371 | } | |
| 372 | else { | |
| 373 | #1.4 Specified by File name | |
| 374 | $oBook->{File} = $sFile; | |
| 375 | return undef unless (-e $sFile); | |
| 376 | ($sBIFF, $iLen) = $oThis->{GetContent}->($sFile); | |
| 377 | return undef unless($sBIFF); | |
| 378 | } | |
| 379 | ||
| 380 | #2. Ready for format | |
| 381 | if ($oWkFmt) { | |
| 382 | $oBook->{FmtClass} = $oWkFmt; | |
| 383 | } | |
| 384 | else { | |
| 385 | # require Spreadsheet::ParseExcel::FmtDefault; | |
| 386 | $oBook->{FmtClass} = new Spreadsheet::ParseExcel::FmtDefault; | |
| 387 | } | |
| 388 | ||
| 389 | #3. Parse content | |
| 390 | my $lPos = 0; | |
| 391 | $sWk = substr($sBIFF, $lPos, 4); | |
| 392 | $lPos += 4; | |
| 393 | my $iEfFlg = 0; | |
| 394 | while($lPos<=$iLen) { | |
| 395 | my($bOp, $bLen) = unpack("v2", $sWk); | |
| 396 | if($bLen) { | |
| 397 | $sWk = substr($sBIFF, $lPos, $bLen); | |
| 398 | $lPos += $bLen; | |
| 399 | } | |
| 400 | #printf STDERR "%4X:%s\n", $bOp, 'UNDEFIND---:' . unpack("H*", $sWk) unless($NameTbl{$bOp}); | |
| 401 | #Check EF, EOF | |
| 402 | if($bOp == 0xEF) { #EF | |
| 403 | $iEfFlg = $bOp; | |
| 404 | } | |
| 405 | elsif($bOp == 0x0A) { #EOF | |
| 406 | undef $iEfFlg; | |
| 407 | } | |
| 408 | unless($iEfFlg) { | |
| 409 | #1. Formula String with No String | |
| 410 | if($oBook->{_PrevPos} && (defined $oThis->{FuncTbl}->{$bOp}) && | |
| 411 | ($bOp != 0x207)) { | |
| 412 | my $iPos = $oBook->{_PrevPos}; | |
| 413 | $oBook->{_PrevPos} = undef; | |
| 414 | my ($iR, $iC, $iF) = @$iPos; | |
| 415 | _NewCell ( | |
| 416 | $oBook, $iR, $iC, | |
| 417 | Kind => 'Formula String', | |
| 418 | Val => '', | |
| 419 | FormatNo=> $iF, | |
| 420 | Format => $oBook->{Format}[$iF], | |
| 421 | Numeric => 0, | |
| 422 | Code => undef, | |
| 423 | Book => $oBook, | |
| 424 | ); | |
| 425 | } | |
| 426 | if(defined $oThis->{FuncTbl}->{$bOp}) { | |
| 427 | $oThis->{FuncTbl}->{$bOp}->($oBook, $bOp, $bLen, $sWk); | |
| 428 | } | |
| 429 | $PREFUNC = $bOp if ($bOp != 0x3C); #Not Continue | |
| 430 | } | |
| 431 | $sWk = substr($sBIFF, $lPos, 4) if(($lPos+4) <= $iLen); | |
| 432 | $lPos += 4; | |
| 433 | #Abort Parse | |
| 434 | if(defined $oBook->{_ParseAbort}) { | |
| 435 | return $oBook; | |
| 436 | } | |
| 437 | } | |
| 438 | #4.return $oBook | |
| 439 | return $oBook; | |
| 440 | } | |
| 441 | #------------------------------------------------------------------------------ | |
| 442 | # _subGetContent (for Spreadsheet::ParseExcel) | |
| 443 | #------------------------------------------------------------------------------ | |
| 444 | sub _subGetContent($) | |
| 445 | { | |
| 446 | my($sFile)=@_; | |
| 447 | my $oOl = OLE::Storage_Lite->new($sFile); | |
| 448 | return (undef, undef) unless($oOl); | |
| 449 | my @aRes = $oOl->getPpsSearch( | |
| 450 | [OLE::Storage_Lite::Asc2Ucs('Book'), | |
| 451 | OLE::Storage_Lite::Asc2Ucs('Workbook')], 1, 1); | |
| 452 | return (undef, undef) if($#aRes < 0); | |
| 453 | #Hack from Herbert | |
| 454 | unless($aRes[0]->{Data}) { | |
| 455 | #Same as OLE::Storage_Lite | |
| 456 | my $oIo; | |
| 457 | #1. $sFile is Ref of scalar | |
| 458 | if(ref($sFile) eq 'SCALAR') { | |
| 459 | $oIo = new IO::Scalar; | |
| 460 | $oIo->open($sFile); | |
| 461 | } | |
| 462 | #2. $sFile is a IO::Handle object | |
| 463 | elsif(UNIVERSAL::isa($sFile, 'IO::Handle')) { | |
| 464 | $oIo = $sFile; | |
| 465 | binmode($oIo); | |
| 466 | } | |
| 467 | #3. $sFile is a simple filename string | |
| 468 | elsif(!ref($sFile)) { | |
| 469 | $oIo = new IO::File; | |
| 470 | $oIo->open("<$sFile") || return undef; | |
| 471 | binmode($oIo); | |
| 472 | } | |
| 473 | my $sWk; | |
| 474 | my $sBuff =''; | |
| 475 | ||
| 476 | while($oIo->read($sWk, 4096)) { #4_096 has no special meanings | |
| 477 | $sBuff .= $sWk; | |
| 478 | } | |
| 479 | $oIo->close(); | |
| 480 | #Not Excel file (simple method) | |
| 481 | return (undef, undef) if (substr($sBuff, 0, 1) ne "\x09"); | |
| 482 | return ($sBuff, length($sBuff)); | |
| 483 | } | |
| 484 | else { | |
| 485 | return ($aRes[0]->{Data}, length($aRes[0]->{Data})); | |
| 486 | } | |
| 487 | } | |
| 488 | #------------------------------------------------------------------------------ | |
| 489 | # _subBOF (for Spreadsheet::ParseExcel) Developers' Kit : P303 | |
| 490 | #------------------------------------------------------------------------------ | |
| 491 | sub _subBOF($$$$){ | |
| 492 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 493 | my ($iVer, $iDt) = unpack("v2", $sWk); | |
| 494 | ||
| 495 | #Workbook Global | |
| 496 | if($iDt==0x0005) { | |
| 497 | $oBook->{Version} = unpack("v", $sWk); | |
| 498 | $oBook->{BIFFVersion} = | |
| 499 | ($oBook->{Version}==verExcel95)? verBIFF5:verBIFF8; | |
| 500 | $oBook->{_CurSheet} = undef; | |
| 501 | $oBook->{_CurSheet_} = -1; | |
| 502 | } | |
| 503 | #Worksheeet or Dialogsheet | |
| 504 | elsif($iDt != 0x0020) { #if($iDt == 0x0010) { | |
| 505 | if(defined $oBook->{_CurSheet_}) { | |
| 506 | $oBook->{_CurSheet} = $oBook->{_CurSheet_} + 1; | |
| 507 | $oBook->{_CurSheet_}++; | |
| 508 | ||
| 509 | ($oBook->{Worksheet}[$oBook->{_CurSheet}]->{SheetVersion}, | |
| 510 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{SheetType},) | |
| 511 | = unpack("v2", $sWk) if(length($sWk) > 4); | |
| 512 | } | |
| 513 | else { | |
| 514 | $oBook->{BIFFVersion} = int($bOp / 0x100); | |
| 515 | if (($oBook->{BIFFVersion} == verBIFF2) || | |
| 516 | ($oBook->{BIFFVersion} == verBIFF3) || | |
| 517 | ($oBook->{BIFFVersion} == verBIFF4)) { | |
| 518 | $oBook->{Version} = $oBook->{BIFFVersion}; | |
| 519 | $oBook->{_CurSheet} = 0; | |
| 520 | $oBook->{Worksheet}[$oBook->{SheetCount}] = | |
| 521 | new Spreadsheet::ParseExcel::Worksheet( | |
| 522 | _Name => '', | |
| 523 | Name => '', | |
| 524 | _Book => $oBook, | |
| 525 | _SheetNo => $oBook->{SheetCount}, | |
| 526 | ); | |
| 527 | $oBook->{SheetCount}++; | |
| 528 | } | |
| 529 | } | |
| 530 | } | |
| 531 | else { | |
| 532 | ($oBook->{_CurSheet_}, $oBook->{_CurSheet}) = | |
| 533 | (((defined $oBook->{_CurSheet})? $oBook->{_CurSheet}: -1), | |
| 534 | undef); | |
| 535 | } | |
| 536 | } | |
| 537 | #------------------------------------------------------------------------------ | |
| 538 | # _subBlank (for Spreadsheet::ParseExcel) DK:P303 | |
| 539 | #------------------------------------------------------------------------------ | |
| 540 | sub _subBlank($$$$) | |
| 541 | { | |
| 542 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 543 | my ($iR, $iC, $iF) = unpack("v3", $sWk); | |
| 544 | _NewCell( | |
| 545 | $oBook, $iR, $iC, | |
| 546 | Kind => 'BLANK', | |
| 547 | Val => '', | |
| 548 | FormatNo=> $iF, | |
| 549 | Format => $oBook->{Format}[$iF], | |
| 550 | Numeric => 0, | |
| 551 | Code => undef, | |
| 552 | Book => $oBook, | |
| 553 | ); | |
| 554 | #2.MaxRow, MaxCol, MinRow, MinCol | |
| 555 | _SetDimension($oBook, $iR, $iC, $iC); | |
| 556 | } | |
| 557 | #------------------------------------------------------------------------------ | |
| 558 | # _subInteger (for Spreadsheet::ParseExcel) Not in DK | |
| 559 | #------------------------------------------------------------------------------ | |
| 560 | sub _subInteger($$$$) | |
| 561 | { | |
| 562 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 563 | my($iR, $iC, $iF, $sTxt, $sDum); | |
| 564 | ||
| 565 | ($iR, $iC, $iF, $sDum, $sTxt) = unpack("v3cv", $sWk); | |
| 566 | _NewCell ( | |
| 567 | $oBook, $iR, $iC, | |
| 568 | Kind => 'INTEGER', | |
| 569 | Val => $sTxt, | |
| 570 | FormatNo=> $iF, | |
| 571 | Format => $oBook->{Format}[$iF], | |
| 572 | Numeric => 0, | |
| 573 | Code => undef, | |
| 574 | Book => $oBook, | |
| 575 | ); | |
| 576 | #2.MaxRow, MaxCol, MinRow, MinCol | |
| 577 | _SetDimension($oBook, $iR, $iC, $iC); | |
| 578 | } | |
| 579 | #------------------------------------------------------------------------------ | |
| 580 | # _subNumber (for Spreadsheet::ParseExcel) : DK: P354 | |
| 581 | #------------------------------------------------------------------------------ | |
| 582 | sub _subNumber($$$$) | |
| 583 | { | |
| 584 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 585 | ||
| 586 | my ($iR, $iC, $iF) = unpack("v3", $sWk); | |
| 587 | my $dVal = _convDval(substr($sWk, 6, 8)); | |
| 588 | _NewCell ( | |
| 589 | $oBook, $iR, $iC, | |
| 590 | Kind => 'Number', | |
| 591 | Val => $dVal, | |
| 592 | FormatNo=> $iF, | |
| 593 | Format => $oBook->{Format}[$iF], | |
| 594 | Numeric => 1, | |
| 595 | Code => undef, | |
| 596 | Book => $oBook, | |
| 597 | ); | |
| 598 | #2.MaxRow, MaxCol, MinRow, MinCol | |
| 599 | _SetDimension($oBook, $iR, $iC, $iC); | |
| 600 | } | |
| 601 | #------------------------------------------------------------------------------ | |
| 602 | # _convDval (for Spreadsheet::ParseExcel) | |
| 603 | #------------------------------------------------------------------------------ | |
| 604 | sub _convDval($) { | |
| 605 | my($sWk)=@_; | |
| 606 | return unpack("d", ($BIGENDIAN)? | |
| 607 | pack("c8", reverse(unpack("c8", $sWk))) : $sWk); | |
| 608 | } | |
| 609 | #------------------------------------------------------------------------------ | |
| 610 | # _subRString (for Spreadsheet::ParseExcel) DK:P405 | |
| 611 | #------------------------------------------------------------------------------ | |
| 612 | sub _subRString($$$$) | |
| 613 | { | |
| 614 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 615 | my($iR, $iC, $iF, $iL, $sTxt); | |
| 616 | ($iR, $iC, $iF, $iL) = unpack("v4", $sWk); | |
| 617 | $sTxt = substr($sWk, 8, $iL); | |
| 618 | ||
| 619 | #Has STRUN | |
| 620 | if(length($sWk) > (8+$iL)) { | |
| 621 | _NewCell ( | |
| 622 | $oBook, $iR, $iC, | |
| 623 | Kind => 'RString', | |
| 624 | Val => $sTxt, | |
| 625 | FormatNo=> $iF, | |
| 626 | Format => $oBook->{Format}[$iF], | |
| 627 | Numeric => 0, | |
| 628 | Code => '_native_', #undef, | |
| 629 | Book => $oBook, | |
| 630 | Rich => substr($sWk, (8+$iL)+1), | |
| 631 | ); | |
| 632 | } | |
| 633 | else { | |
| 634 | _NewCell ( | |
| 635 | $oBook, $iR, $iC, | |
| 636 | Kind => 'RString', | |
| 637 | Val => $sTxt, | |
| 638 | FormatNo=> $iF, | |
| 639 | Format => $oBook->{Format}[$iF], | |
| 640 | Numeric => 0, | |
| 641 | Code => '_native_', | |
| 642 | Book => $oBook, | |
| 643 | ); | |
| 644 | } | |
| 645 | #2.MaxRow, MaxCol, MinRow, MinCol | |
| 646 | _SetDimension($oBook, $iR, $iC, $iC); | |
| 647 | } | |
| 648 | #------------------------------------------------------------------------------ | |
| 649 | # _subBoolErr (for Spreadsheet::ParseExcel) DK:P306 | |
| 650 | #------------------------------------------------------------------------------ | |
| 651 | sub _subBoolErr($$$$) | |
| 652 | { | |
| 653 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 654 | my ($iR, $iC, $iF) = unpack("v3", $sWk); | |
| 655 | my ($iVal, $iFlg) = unpack("cc", substr($sWk, 6, 2)); | |
| 656 | my $sTxt = DecodeBoolErr($iVal, $iFlg); | |
| 657 | ||
| 658 | _NewCell ( | |
| 659 | $oBook, $iR, $iC, | |
| 660 | Kind => 'BoolError', | |
| 661 | Val => $sTxt, | |
| 662 | FormatNo=> $iF, | |
| 663 | Format => $oBook->{Format}[$iF], | |
| 664 | Numeric => 0, | |
| 665 | Code => undef, | |
| 666 | Book => $oBook, | |
| 667 | ); | |
| 668 | #2.MaxRow, MaxCol, MinRow, MinCol | |
| 669 | _SetDimension($oBook, $iR, $iC, $iC); | |
| 670 | } | |
| 671 | #------------------------------------------------------------------------------ | |
| 672 | # _subRK (for Spreadsheet::ParseExcel) DK:P401 | |
| 673 | #------------------------------------------------------------------------------ | |
| 674 | sub _subRK($$$$) | |
| 675 | { | |
| 676 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 677 | my ($iR, $iC) = unpack("v3", $sWk); | |
| 678 | ||
| 679 | my($iF, $sTxt)= _UnpackRKRec(substr($sWk, 4, 6)); | |
| 680 | _NewCell ( | |
| 681 | $oBook, $iR, $iC, | |
| 682 | Kind => 'RK', | |
| 683 | Val => $sTxt, | |
| 684 | FormatNo=> $iF, | |
| 685 | Format => $oBook->{Format}[$iF], | |
| 686 | Numeric => 1, | |
| 687 | Code => undef, | |
| 688 | Book => $oBook, | |
| 689 | ); | |
| 690 | #2.MaxRow, MaxCol, MinRow, MinCol | |
| 691 | _SetDimension($oBook, $iR, $iC, $iC); | |
| 692 | } | |
| 693 | #------------------------------------------------------------------------------ | |
| 694 | # _subArray (for Spreadsheet::ParseExcel) DK:P297 | |
| 695 | #------------------------------------------------------------------------------ | |
| 696 | sub _subArray($$$$) | |
| 697 | { | |
| 698 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 699 | my ($iBR, $iER, $iBC, $iEC) = unpack("v2c2", $sWk); | |
| 700 | ||
| 701 | } | |
| 702 | #------------------------------------------------------------------------------ | |
| 703 | # _subFormula (for Spreadsheet::ParseExcel) DK:P336 | |
| 704 | #------------------------------------------------------------------------------ | |
| 705 | sub _subFormula($$$$) | |
| 706 | { | |
| 707 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 708 | my($iR, $iC, $iF) = unpack("v3", $sWk); | |
| 709 | ||
| 710 | my ($iFlg) = unpack("v", substr($sWk,12,2)); | |
| 711 | if($iFlg == 0xFFFF) { | |
| 712 | my($iKind) = unpack("c", substr($sWk, 6, 1)); | |
| 713 | my($iVal) = unpack("c", substr($sWk, 8, 1)); | |
| 714 | ||
| 715 | if(($iKind==1) or ($iKind==2)) { | |
| 716 | my $sTxt = ($iKind == 1)? DecodeBoolErr($iVal, 0):DecodeBoolErr($iVal, 1); | |
| 717 | _NewCell ( | |
| 718 | $oBook, $iR, $iC, | |
| 719 | Kind => 'Formulra Bool', | |
| 720 | Val => $sTxt, | |
| 721 | FormatNo=> $iF, | |
| 722 | Format => $oBook->{Format}[$iF], | |
| 723 | Numeric => 0, | |
| 724 | Code => undef, | |
| 725 | Book => $oBook, | |
| 726 | ); | |
| 727 | } | |
| 728 | else { # Result (Reserve Only) | |
| 729 | $oBook->{_PrevPos} = [$iR, $iC, $iF]; | |
| 730 | } | |
| 731 | } | |
| 732 | else { | |
| 733 | my $dVal = _convDval(substr($sWk, 6, 8)); | |
| 734 | _NewCell ( | |
| 735 | $oBook, $iR, $iC, | |
| 736 | Kind => 'Formula Number', | |
| 737 | Val => $dVal, | |
| 738 | FormatNo=> $iF, | |
| 739 | Format => $oBook->{Format}[$iF], | |
| 740 | Numeric => 1, | |
| 741 | Code => undef, | |
| 742 | Book => $oBook, | |
| 743 | ); | |
| 744 | } | |
| 745 | #2.MaxRow, MaxCol, MinRow, MinCol | |
| 746 | _SetDimension($oBook, $iR, $iC, $iC); | |
| 747 | } | |
| 748 | #------------------------------------------------------------------------------ | |
| 749 | # _subString (for Spreadsheet::ParseExcel) DK:P414 | |
| 750 | #------------------------------------------------------------------------------ | |
| 751 | sub _subString($$$$) | |
| 752 | { | |
| 753 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 754 | #Position (not enough for ARRAY) | |
| 755 | ||
| 756 | my $iPos = $oBook->{_PrevPos}; | |
| 757 | return undef unless($iPos); | |
| 758 | $oBook->{_PrevPos} = undef; | |
| 759 | my ($iR, $iC, $iF) = @$iPos; | |
| 760 | ||
| 761 | my ($iLen, $sTxt, $sCode); | |
| 762 | if($oBook->{BIFFVersion} == verBIFF8) { | |
| 763 | my( $raBuff, $iLen) = _convBIFF8String($oBook, $sWk, 1); | |
| 764 | $sTxt = $raBuff->[0]; | |
| 765 | $sCode = ($raBuff->[1])? 'ucs2': undef; | |
| 766 | } | |
| 767 | elsif($oBook->{BIFFVersion} == verBIFF5) { | |
| 768 | $sCode = '_native_'; | |
| 769 | $iLen = unpack("v", $sWk); | |
| 770 | $sTxt = substr($sWk, 2, $iLen); | |
| 771 | } | |
| 772 | else { | |
| 773 | $sCode = '_native_'; | |
| 774 | $iLen = unpack("c", $sWk); | |
| 775 | $sTxt = substr($sWk, 1, $iLen); | |
| 776 | } | |
| 777 | _NewCell ( | |
| 778 | $oBook, $iR, $iC, | |
| 779 | Kind => 'String', | |
| 780 | Val => $sTxt, | |
| 781 | FormatNo=> $iF, | |
| 782 | Format => $oBook->{Format}[$iF], | |
| 783 | Numeric => 0, | |
| 784 | Code => $sCode, | |
| 785 | Book => $oBook, | |
| 786 | ); | |
| 787 | #2.MaxRow, MaxCol, MinRow, MinCol | |
| 788 | _SetDimension($oBook, $iR, $iC, $iC); | |
| 789 | } | |
| 790 | #------------------------------------------------------------------------------ | |
| 791 | # _subLabel (for Spreadsheet::ParseExcel) DK:P344 | |
| 792 | #------------------------------------------------------------------------------ | |
| 793 | sub _subLabel($$$$) | |
| 794 | { | |
| 795 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 796 | my($iR, $iC, $iF) = unpack("v3", $sWk); | |
| 797 | my ($sLbl, $sCode); | |
| 798 | #BIFF8 | |
| 799 | if($oBook->{BIFFVersion} >= verBIFF8) { | |
| 800 | my ( $raBuff, $iLen, $iStPos, $iLenS) = | |
| 801 | _convBIFF8String($oBook, substr($sWk,6), 1); | |
| 802 | $sLbl = $raBuff->[0]; | |
| 803 | $sCode = ($raBuff->[1])? 'ucs2': undef; | |
| 804 | } | |
| 805 | #Before BIFF8 | |
| 806 | else { | |
| 807 | $sLbl = substr($sWk,8); | |
| 808 | $sCode = '_native_'; | |
| 809 | } | |
| 810 | _NewCell ( | |
| 811 | $oBook, $iR, $iC, | |
| 812 | Kind => 'Label', | |
| 813 | Val => $sLbl, | |
| 814 | FormatNo=> $iF, | |
| 815 | Format => $oBook->{Format}[$iF], | |
| 816 | Numeric => 0, | |
| 817 | Code => $sCode, | |
| 818 | Book => $oBook, | |
| 819 | ); | |
| 820 | #2.MaxRow, MaxCol, MinRow, MinCol | |
| 821 | _SetDimension($oBook, $iR, $iC, $iC); | |
| 822 | } | |
| 823 | #------------------------------------------------------------------------------ | |
| 824 | # _subMulRK (for Spreadsheet::ParseExcel) DK:P349 | |
| 825 | #------------------------------------------------------------------------------ | |
| 826 | sub _subMulRK($$$$) | |
| 827 | { | |
| 828 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 829 | return if ($oBook->{SheetCount}<=0); | |
| 830 | ||
| 831 | my ($iR, $iSc) = unpack("v2", $sWk); | |
| 832 | my $iEc = unpack("v", substr($sWk, length($sWk) -2, 2)); | |
| 833 | ||
| 834 | my $iPos = 4; | |
| 835 | for(my $iC=$iSc; $iC<=$iEc; $iC++) { | |
| 836 | my($iF, $lVal) = _UnpackRKRec(substr($sWk, $iPos, 6), $iR, $iC); | |
| 837 | _NewCell ( | |
| 838 | $oBook, $iR, $iC, | |
| 839 | Kind => 'MulRK', | |
| 840 | Val => $lVal, | |
| 841 | FormatNo=> $iF, | |
| 842 | Format => $oBook->{Format}[$iF], | |
| 843 | Numeric => 1, | |
| 844 | Code => undef, | |
| 845 | Book => $oBook, | |
| 846 | ); | |
| 847 | $iPos += 6; | |
| 848 | } | |
| 849 | #2.MaxRow, MaxCol, MinRow, MinCol | |
| 850 | _SetDimension($oBook, $iR, $iSc, $iEc); | |
| 851 | } | |
| 852 | #------------------------------------------------------------------------------ | |
| 853 | # _subMulBlank (for Spreadsheet::ParseExcel) DK:P349 | |
| 854 | #------------------------------------------------------------------------------ | |
| 855 | sub _subMulBlank($$$$) | |
| 856 | { | |
| 857 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 858 | my ($iR, $iSc) = unpack("v2", $sWk); | |
| 859 | my $iEc = unpack("v", substr($sWk, length($sWk)-2, 2)); | |
| 860 | my $iPos = 4; | |
| 861 | for(my $iC=$iSc; $iC<=$iEc; $iC++) { | |
| 862 | my $iF = unpack('v', substr($sWk, $iPos, 2)); | |
| 863 | _NewCell ( | |
| 864 | $oBook, $iR, $iC, | |
| 865 | Kind => 'MulBlank', | |
| 866 | Val => '', | |
| 867 | FormatNo=> $iF, | |
| 868 | Format => $oBook->{Format}[$iF], | |
| 869 | Numeric => 0, | |
| 870 | Code => undef, | |
| 871 | Book => $oBook, | |
| 872 | ); | |
| 873 | $iPos+=2; | |
| 874 | } | |
| 875 | #2.MaxRow, MaxCol, MinRow, MinCol | |
| 876 | _SetDimension($oBook, $iR, $iSc, $iEc); | |
| 877 | } | |
| 878 | #------------------------------------------------------------------------------ | |
| 879 | # _subLabelSST (for Spreadsheet::ParseExcel) DK: P345 | |
| 880 | #------------------------------------------------------------------------------ | |
| 881 | sub _subLabelSST($$$$) | |
| 882 | { | |
| 883 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 884 | my ($iR, $iC, $iF, $iIdx) = unpack('v3V', $sWk); | |
| 885 | ||
| 886 | _NewCell ( | |
| 887 | $oBook, $iR, $iC, | |
| 888 | Kind => 'PackedIdx', | |
| 889 | Val => $oBook->{PkgStr}[$iIdx]->{Text}, | |
| 890 | FormatNo=> $iF, | |
| 891 | Format => $oBook->{Format}[$iF], | |
| 892 | Numeric => 0, | |
| 893 | Code => ($oBook->{PkgStr}[$iIdx]->{Unicode})? 'ucs2': undef, | |
| 894 | Book => $oBook, | |
| 895 | Rich => $oBook->{PkgStr}[$iIdx]->{Rich}, | |
| 896 | ); | |
| 897 | ||
| 898 | #2.MaxRow, MaxCol, MinRow, MinCol | |
| 899 | _SetDimension($oBook, $iR, $iC, $iC); | |
| 900 | } | |
| 901 | #------------------------------------------------------------------------------ | |
| 902 | # _subFlg1904 (for Spreadsheet::ParseExcel) DK:P296 | |
| 903 | #------------------------------------------------------------------------------ | |
| 904 | sub _subFlg1904($$$$) | |
| 905 | { | |
| 906 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 907 | $oBook->{Flg1904} = unpack("v", $sWk); | |
| 908 | } | |
| 909 | #------------------------------------------------------------------------------ | |
| 910 | # _subRow (for Spreadsheet::ParseExcel) DK:P403 | |
| 911 | #------------------------------------------------------------------------------ | |
| 912 | sub _subRow($$$$) | |
| 913 | { | |
| 914 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 915 | return undef unless(defined $oBook->{_CurSheet}); | |
| 916 | ||
| 917 | #0. Get Worksheet info (MaxRow, MaxCol, MinRow, MinCol) | |
| 918 | my($iR, $iSc, $iEc, $iHght, $undef1, $undef2, $iGr, $iXf) = unpack("v8", $sWk); | |
| 919 | $iEc--; | |
| 920 | ||
| 921 | #1. RowHeight | |
| 922 | if($iGr & 0x20) { #Height = 0 | |
| 923 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{RowHeight}[$iR] = 0; | |
| 924 | } | |
| 925 | else { | |
| 926 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{RowHeight}[$iR] = $iHght/20.0; | |
| 927 | } | |
| 928 | ||
| 929 | #2.MaxRow, MaxCol, MinRow, MinCol | |
| 930 | _SetDimension($oBook, $iR, $iSc, $iEc); | |
| 931 | } | |
| 932 | #------------------------------------------------------------------------------ | |
| 933 | # _SetDimension (for Spreadsheet::ParseExcel) | |
| 934 | #------------------------------------------------------------------------------ | |
| 935 | sub _SetDimension($$$$) | |
| 936 | { | |
| 937 | my($oBook, $iR, $iSc, $iEc)=@_; | |
| 938 | return undef unless(defined $oBook->{_CurSheet}); | |
| 939 | ||
| 940 | #2.MaxRow, MaxCol, MinRow, MinCol | |
| 941 | #2.1 MinRow | |
| 942 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{MinRow} = $iR | |
| 943 | unless (defined $oBook->{Worksheet}[$oBook->{_CurSheet}]->{MinRow}) and | |
| 944 | ($oBook->{Worksheet}[$oBook->{_CurSheet}]->{MinRow} <= $iR); | |
| 945 | ||
| 946 | #2.2 MaxRow | |
| 947 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{MaxRow} = $iR | |
| 948 | unless (defined $oBook->{Worksheet}[$oBook->{_CurSheet}]->{MaxRow}) and | |
| 949 | ($oBook->{Worksheet}[$oBook->{_CurSheet}]->{MaxRow} > $iR); | |
| 950 | #2.3 MinCol | |
| 951 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{MinCol} = $iSc | |
| 952 | unless (defined $oBook->{Worksheet}[$oBook->{_CurSheet}]->{MinCol}) and | |
| 953 | ($oBook->{Worksheet}[$oBook->{_CurSheet}]->{MinCol} <= $iSc); | |
| 954 | #2.4 MaxCol | |
| 955 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{MaxCol} = $iEc | |
| 956 | unless (defined $oBook->{Worksheet}[$oBook->{_CurSheet}]->{MaxCol}) and | |
| 957 | ($oBook->{Worksheet}[$oBook->{_CurSheet}]->{MaxCol} > $iEc); | |
| 958 | ||
| 959 | } | |
| 960 | #------------------------------------------------------------------------------ | |
| 961 | # _subDefaultRowHeight (for Spreadsheet::ParseExcel) DK: P318 | |
| 962 | #------------------------------------------------------------------------------ | |
| 963 | sub _subDefaultRowHeight($$$$) | |
| 964 | { | |
| 965 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 966 | return undef unless(defined $oBook->{_CurSheet}); | |
| 967 | #1. RowHeight | |
| 968 | my($iDum, $iHght) = unpack("v2", $sWk); | |
| 969 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{DefRowHeight} = $iHght/20; | |
| 970 | ||
| 971 | } | |
| 972 | #------------------------------------------------------------------------------ | |
| 973 | # _subStandardWidth(for Spreadsheet::ParseExcel) DK:P413 | |
| 974 | #------------------------------------------------------------------------------ | |
| 975 | sub _subStandardWidth($$$$) | |
| 976 | { | |
| 977 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 978 | my $iW = unpack("v", $sWk); | |
| 979 | $oBook->{StandardWidth}= _adjustColWidth($oBook, $iW); | |
| 980 | } | |
| 981 | #------------------------------------------------------------------------------ | |
| 982 | # _subDefColWidth(for Spreadsheet::ParseExcel) DK:P319 | |
| 983 | #------------------------------------------------------------------------------ | |
| 984 | sub _subDefColWidth($$$$) | |
| 985 | { | |
| 986 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 987 | return undef unless(defined $oBook->{_CurSheet}); | |
| 988 | my $iW = unpack("v", $sWk); | |
| 989 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{DefColWidth}= _adjustColWidth($oBook, $iW); | |
| 990 | } | |
| 991 | #------------------------------------------------------------------------------ | |
| 992 | # _adjustColWidth (for Spreadsheet::ParseExcel) | |
| 993 | #------------------------------------------------------------------------------ | |
| 994 | sub _adjustColWidth($$) { | |
| 995 | my($oBook, $iW)=@_; | |
| 996 | return (($iW -0xA0)/256); | |
| 997 | # ($oBook->{Worksheet}[$oBook->{_CurSheet}]->{SheetVersion} == verExcel97)? | |
| 998 | # (($iW -0xA0)/256) : $iW; | |
| 999 | } | |
| 1000 | #------------------------------------------------------------------------------ | |
| 1001 | # _subColInfo (for Spreadsheet::ParseExcel) DK:P309 | |
| 1002 | #------------------------------------------------------------------------------ | |
| 1003 | sub _subColInfo($$$$) | |
| 1004 | { | |
| 1005 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 1006 | return undef unless(defined $oBook->{_CurSheet}); | |
| 1007 | my($iSc, $iEc, $iW, $iXF, $iGr) = unpack("v5", $sWk); | |
| 1008 | for(my $i= $iSc; $i<=$iEc; $i++) { | |
| 1009 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{ColWidth}[$i] = | |
| 1010 | ($iGr & 0x01)? 0: _adjustColWidth($oBook, $iW); | |
| 1011 | #0x01 means HIDDEN | |
| 1012 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{ColFmtNo}[$i] = $iXF; | |
| 1013 | # $oBook->{Worksheet}[$oBook->{_CurSheet}]->{ColCr}[$i] = $iGr; #Not Implemented | |
| 1014 | } | |
| 1015 | } | |
| 1016 | #------------------------------------------------------------------------------ | |
| 1017 | # _subSST (for Spreadsheet::ParseExcel) DK:P413 | |
| 1018 | #------------------------------------------------------------------------------ | |
| 1019 | sub _subSST($$$$) | |
| 1020 | { | |
| 1021 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 1022 | _subStrWk($oBook, substr($sWk, 8)); | |
| 1023 | } | |
| 1024 | #------------------------------------------------------------------------------ | |
| 1025 | # _subContinue (for Spreadsheet::ParseExcel) DK:P311 | |
| 1026 | #------------------------------------------------------------------------------ | |
| 1027 | sub _subContinue($$$$) | |
| 1028 | { | |
| 1029 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 1030 | =cmmt | |
| 1031 | if(defined $oThis->{FuncTbl}->{$bOp}) { | |
| 1032 | $oThis->{FuncTbl}->{$PREFUNC}->($oBook, $bOp, $bLen, $sWk); | |
| 1033 | } | |
| 1034 | =cut | |
| 1035 | _subStrWk($oBook, $sWk, 1) if($PREFUNC == 0xFC); | |
| 1036 | } | |
| 1037 | #------------------------------------------------------------------------------ | |
| 1038 | # _subWriteAccess (for Spreadsheet::ParseExcel) DK:P451 | |
| 1039 | #------------------------------------------------------------------------------ | |
| 1040 | sub _subWriteAccess($$$$) | |
| 1041 | { | |
| 1042 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 1043 | return if (defined $oBook->{_Author}); | |
| 1044 | ||
| 1045 | #BIFF8 | |
| 1046 | if($oBook->{BIFFVersion} >= verBIFF8) { | |
| 1047 | $oBook->{Author} = _convBIFF8String($oBook, $sWk); | |
| 1048 | } | |
| 1049 | #Before BIFF8 | |
| 1050 | else { | |
| 1051 | my($iLen) = unpack("c", $sWk); | |
| 1052 | $oBook->{Author} = $oBook->{FmtClass}->TextFmt(substr($sWk, 1, $iLen), '_native_'); | |
| 1053 | } | |
| 1054 | } | |
| 1055 | #------------------------------------------------------------------------------ | |
| 1056 | # _convBIFF8String (for Spreadsheet::ParseExcel) | |
| 1057 | #------------------------------------------------------------------------------ | |
| 1058 | sub _convBIFF8String($$;$){ | |
| 1059 | my($oBook, $sWk, $iCnvFlg) = @_; | |
| 1060 | my($iLen, $iFlg) = unpack("vc", $sWk); | |
| 1061 | my($iHigh, $iExt, $iRich) = ($iFlg & 0x01, $iFlg & 0x04, $iFlg & 0x08); | |
| 1062 | my($iStPos, $iExtCnt, $iRichCnt, $sStr); | |
| 1063 | #2. Rich and Ext | |
| 1064 | if($iRich && $iExt) { | |
| 1065 | $iStPos = 9; | |
| 1066 | ($iRichCnt, $iExtCnt) = unpack('vV', substr($sWk, 3, 6)); | |
| 1067 | } | |
| 1068 | elsif($iRich) { #Only Rich | |
| 1069 | $iStPos = 5; | |
| 1070 | $iRichCnt = unpack('v', substr($sWk, 3, 2)); | |
| 1071 | $iExtCnt = 0; | |
| 1072 | } | |
| 1073 | elsif($iExt) { #Only Ext | |
| 1074 | $iStPos = 7; | |
| 1075 | $iRichCnt = 0; | |
| 1076 | $iExtCnt = unpack('V', substr($sWk, 3, 4)); | |
| 1077 | } | |
| 1078 | else { #Nothing Special | |
| 1079 | $iStPos = 3; | |
| 1080 | $iExtCnt = 0; | |
| 1081 | $iRichCnt = 0; | |
| 1082 | } | |
| 1083 | #3.Get String | |
| 1084 | if($iHigh) { #Compressed | |
| 1085 | $iLen *= 2; | |
| 1086 | $sStr = substr($sWk, $iStPos, $iLen); | |
| 1087 | _SwapForUnicode(\$sStr); | |
| 1088 | $sStr = $oBook->{FmtClass}->TextFmt($sStr, 'ucs2') unless($iCnvFlg); | |
| 1089 | } | |
| 1090 | else { #Not Compressed | |
| 1091 | $sStr = substr($sWk, $iStPos, $iLen); | |
| 1092 | $sStr = $oBook->{FmtClass}->TextFmt($sStr, undef) unless($iCnvFlg); | |
| 1093 | } | |
| 1094 | ||
| 1095 | #4. return | |
| 1096 | if(wantarray) { | |
| 1097 | #4.1 Get Rich and Ext | |
| 1098 | if(length($sWk) < $iStPos + $iLen+ $iRichCnt*4+$iExtCnt) { | |
| 1099 | return ([undef, $iHigh, undef, undef], | |
| 1100 | $iStPos + $iLen+ $iRichCnt*4+$iExtCnt, $iStPos, $iLen); | |
| 1101 | } | |
| 1102 | else { | |
| 1103 | return ([$sStr, $iHigh, | |
| 1104 | substr($sWk, $iStPos + $iLen, $iRichCnt*4), | |
| 1105 | substr($sWk, $iStPos + $iLen+ $iRichCnt*4, $iExtCnt)], | |
| 1106 | $iStPos + $iLen+ $iRichCnt*4+$iExtCnt, $iStPos, $iLen); | |
| 1107 | } | |
| 1108 | } | |
| 1109 | else { | |
| 1110 | return $sStr; | |
| 1111 | } | |
| 1112 | } | |
| 1113 | #------------------------------------------------------------------------------ | |
| 1114 | # _subXF (for Spreadsheet::ParseExcel) DK:P453 | |
| 1115 | #------------------------------------------------------------------------------ | |
| 1116 | sub _subXF($$$$) | |
| 1117 | { | |
| 1118 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 1119 | ||
| 1120 | my ($iFnt, $iIdx); | |
| 1121 | my($iLock, $iHidden, $iStyle, $i123, $iAlH, $iWrap, $iAlV, $iJustL, $iRotate, | |
| 1122 | $iInd, $iShrink, $iMerge, $iReadDir, $iBdrD, | |
| 1123 | $iBdrSL, $iBdrSR, $iBdrST, $iBdrSB, $iBdrSD, | |
| 1124 | $iBdrCL, $iBdrCR, $iBdrCT, $iBdrCB, $iBdrCD, | |
| 1125 | $iFillP, $iFillCF, $iFillCB); | |
| 1126 | ||
| 1127 | if($oBook->{BIFFVersion} == verBIFF8) { | |
| 1128 | my ($iGen, $iAlign, $iGen2, $iBdr1, $iBdr2, $iBdr3, $iPtn ); | |
| 1129 | ||
| 1130 | ($iFnt, $iIdx, $iGen, $iAlign, $iGen2, $iBdr1, $iBdr2, $iBdr3, $iPtn ) | |
| 1131 | = unpack("v7Vv", $sWk); | |
| 1132 | $iLock = ($iGen & 0x01)? 1:0; | |
| 1133 | $iHidden = ($iGen & 0x02)? 1:0; | |
| 1134 | $iStyle = ($iGen & 0x04)? 1:0; | |
| 1135 | $i123 = ($iGen & 0x08)? 1:0; | |
| 1136 | $iAlH = ($iAlign & 0x07); | |
| 1137 | $iWrap = ($iAlign & 0x08)? 1:0; | |
| 1138 | $iAlV = ($iAlign & 0x70) / 0x10; | |
| 1139 | $iJustL = ($iAlign & 0x80)? 1:0; | |
| 1140 | ||
| 1141 | $iRotate = (($iAlign & 0xFF00) / 0x100) & 0x00FF; | |
| 1142 | $iRotate = 90 if($iRotate == 255); | |
| 1143 | $iRotate = 90 - $iRotate if($iRotate > 90); | |
| 1144 | ||
| 1145 | $iInd = ($iGen2 & 0x0F); | |
| 1146 | $iShrink = ($iGen2 & 0x10)? 1:0; | |
| 1147 | $iMerge = ($iGen2 & 0x20)? 1:0; | |
| 1148 | $iReadDir = (($iGen2 & 0xC0) / 0x40) & 0x03; | |
| 1149 | $iBdrSL = $iBdr1 & 0x0F; | |
| 1150 | $iBdrSR = (($iBdr1 & 0xF0) / 0x10) & 0x0F; | |
| 1151 | $iBdrST = (($iBdr1 & 0xF00) / 0x100) & 0x0F; | |
| 1152 | $iBdrSB = (($iBdr1 & 0xF000) / 0x1000) & 0x0F; | |
| 1153 | ||
| 1154 | $iBdrCL = (($iBdr2 & 0x7F)) & 0x7F; | |
| 1155 | $iBdrCR = (($iBdr2 & 0x3F80) / 0x80) & 0x7F; | |
| 1156 | $iBdrD = (($iBdr2 & 0xC000) / 0x4000) & 0x3; | |
| 1157 | ||
| 1158 | $iBdrCT = (($iBdr3 & 0x7F)) & 0x7F; | |
| 1159 | $iBdrCB = (($iBdr3 & 0x3F80) / 0x80) & 0x7F; | |
| 1160 | $iBdrCD = (($iBdr3 & 0x1FC000) / 0x4000) & 0x7F; | |
| 1161 | $iBdrSD = (($iBdr3 & 0x1E00000) / 0x200000) & 0xF; | |
| 1162 | $iFillP = (($iBdr3 & 0xFC000000) / 0x4000000) & 0x3F; | |
| 1163 | ||
| 1164 | $iFillCF = ($iPtn & 0x7F); | |
| 1165 | $iFillCB = (($iPtn & 0x3F80) / 0x80) & 0x7F; | |
| 1166 | } | |
| 1167 | else { | |
| 1168 | my ($iGen, $iAlign, $iPtn, $iPtn2, $iBdr1, $iBdr2); | |
| 1169 | ||
| 1170 | ($iFnt, $iIdx, $iGen, $iAlign, $iPtn, $iPtn2, $iBdr1, $iBdr2) | |
| 1171 | = unpack("v8", $sWk); | |
| 1172 | $iLock = ($iGen & 0x01)? 1:0; | |
| 1173 | $iHidden = ($iGen & 0x02)? 1:0; | |
| 1174 | $iStyle = ($iGen & 0x04)? 1:0; | |
| 1175 | $i123 = ($iGen & 0x08)? 1:0; | |
| 1176 | ||
| 1177 | $iAlH = ($iAlign & 0x07); | |
| 1178 | $iWrap = ($iAlign & 0x08)? 1:0; | |
| 1179 | $iAlV = ($iAlign & 0x70) / 0x10; | |
| 1180 | $iJustL = ($iAlign & 0x80)? 1:0; | |
| 1181 | ||
| 1182 | $iRotate = (($iAlign & 0x300) / 0x100) & 0x3; | |
| 1183 | ||
| 1184 | $iFillCF = ($iPtn & 0x7F); | |
| 1185 | $iFillCB = (($iPtn & 0x1F80) / 0x80) & 0x7F; | |
| 1186 | ||
| 1187 | $iFillP = ($iPtn2 & 0x3F); | |
| 1188 | $iBdrSB = (($iPtn2 & 0x1C0) / 0x40) & 0x7; | |
| 1189 | $iBdrCB = (($iPtn2 & 0xFE00) / 0x200) & 0x7F; | |
| 1190 | ||
| 1191 | $iBdrST = ($iBdr1 & 0x07); | |
| 1192 | $iBdrSL = (($iBdr1 & 0x38) / 0x8) & 0x07; | |
| 1193 | $iBdrSR = (($iBdr1 & 0x1C0) / 0x40) & 0x07; | |
| 1194 | $iBdrCT = (($iBdr1 & 0xFE00) / 0x200) & 0x7F; | |
| 1195 | ||
| 1196 | $iBdrCL = ($iBdr2 & 0x7F) & 0x7F; | |
| 1197 | $iBdrCR = (($iBdr2 & 0x3F80) / 0x80) & 0x7F; | |
| 1198 | } | |
| 1199 | ||
| 1200 | push @{$oBook->{Format}} , | |
| 1201 | Spreadsheet::ParseExcel::Format->new ( | |
| 1202 | FontNo => $iFnt, | |
| 1203 | Font => $oBook->{Font}[$iFnt], | |
| 1204 | FmtIdx => $iIdx, | |
| 1205 | ||
| 1206 | Lock => $iLock, | |
| 1207 | Hidden => $iHidden, | |
| 1208 | Style => $iStyle, | |
| 1209 | Key123 => $i123, | |
| 1210 | AlignH => $iAlH, | |
| 1211 | Wrap => $iWrap, | |
| 1212 | AlignV => $iAlV, | |
| 1213 | JustLast => $iJustL, | |
| 1214 | Rotate => $iRotate, | |
| 1215 | ||
| 1216 | Indent => $iInd, | |
| 1217 | Shrink => $iShrink, | |
| 1218 | Merge => $iMerge, | |
| 1219 | ReadDir => $iReadDir, | |
| 1220 | ||
| 1221 | BdrStyle => [$iBdrSL, $iBdrSR, $iBdrST, $iBdrSB], | |
| 1222 | BdrColor => [$iBdrCL, $iBdrCR, $iBdrCT, $iBdrCB], | |
| 1223 | BdrDiag => [$iBdrD, $iBdrSD, $iBdrCD], | |
| 1224 | Fill => [$iFillP, $iFillCF, $iFillCB], | |
| 1225 | ); | |
| 1226 | } | |
| 1227 | #------------------------------------------------------------------------------ | |
| 1228 | # _subFormat (for Spreadsheet::ParseExcel) DK: P336 | |
| 1229 | #------------------------------------------------------------------------------ | |
| 1230 | sub _subFormat($$$$) | |
| 1231 | { | |
| 1232 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 1233 | my $sFmt; | |
| 1234 | if (($oBook->{BIFFVersion} == verBIFF2) || | |
| 1235 | ($oBook->{BIFFVersion} == verBIFF3) || | |
| 1236 | ($oBook->{BIFFVersion} == verBIFF4) || | |
| 1237 | ($oBook->{BIFFVersion} == verBIFF5) ) { | |
| 1238 | $sFmt = substr($sWk, 3, unpack('c', substr($sWk, 2, 1))); | |
| 1239 | $sFmt = $oBook->{FmtClass}->TextFmt($sFmt, '_native_'); | |
| 1240 | } | |
| 1241 | else { | |
| 1242 | $sFmt = _convBIFF8String($oBook, substr($sWk, 2)); | |
| 1243 | } | |
| 1244 | $oBook->{FormatStr}->{unpack('v', substr($sWk, 0, 2))} = $sFmt; | |
| 1245 | } | |
| 1246 | #------------------------------------------------------------------------------ | |
| 1247 | # _subPalette (for Spreadsheet::ParseExcel) DK: P393 | |
| 1248 | #------------------------------------------------------------------------------ | |
| 1249 | sub _subPalette($$$$) | |
| 1250 | { | |
| 1251 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 1252 | for(my $i=0;$i<unpack('v', $sWk);$i++) { | |
| 1253 | # push @aColor, unpack('H6', substr($sWk, $i*4+2)); | |
| 1254 | $aColor[$i+8] = unpack('H6', substr($sWk, $i*4+2)); | |
| 1255 | } | |
| 1256 | } | |
| 1257 | #------------------------------------------------------------------------------ | |
| 1258 | # _subFont (for Spreadsheet::ParseExcel) DK:P333 | |
| 1259 | #------------------------------------------------------------------------------ | |
| 1260 | sub _subFont($$$$) | |
| 1261 | { | |
| 1262 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 1263 | my($iHeight, $iAttr, $iCIdx, $iBold, $iSuper, $iUnderline, $sFntName); | |
| 1264 | my($bBold, $bItalic, $bUnderline, $bStrikeout); | |
| 1265 | ||
| 1266 | if($oBook->{BIFFVersion} == verBIFF8) { | |
| 1267 | ($iHeight, $iAttr, $iCIdx, $iBold, $iSuper, $iUnderline) = | |
| 1268 | unpack("v5c", $sWk); | |
| 1269 | my($iSize, $iHigh) = unpack('cc', substr($sWk, 14, 2)); | |
| 1270 | if($iHigh) { | |
| 1271 | $sFntName = substr($sWk, 16, $iSize*2); | |
| 1272 | _SwapForUnicode(\$sFntName); | |
| 1273 | $sFntName = $oBook->{FmtClass}->TextFmt($sFntName, 'ucs2'); | |
| 1274 | } | |
| 1275 | else { | |
| 1276 | $sFntName = substr($sWk, 16, $iSize); | |
| 1277 | $sFntName = $oBook->{FmtClass}->TextFmt($sFntName, '_native_'); | |
| 1278 | } | |
| 1279 | $bBold = ($iBold >= 0x2BC)? 1: 0; | |
| 1280 | $bItalic = ($iAttr & 0x02)? 1: 0; | |
| 1281 | $bStrikeout = ($iAttr & 0x08)? 1: 0; | |
| 1282 | $bUnderline = ($iUnderline)? 1: 0; | |
| 1283 | } | |
| 1284 | elsif($oBook->{BIFFVersion} == verBIFF5) { | |
| 1285 | ($iHeight, $iAttr, $iCIdx, $iBold, $iSuper, $iUnderline) = | |
| 1286 | unpack("v5c", $sWk); | |
| 1287 | $sFntName = $oBook->{FmtClass}->TextFmt( | |
| 1288 | substr($sWk, 15, unpack("c", substr($sWk, 14, 1))), | |
| 1289 | '_native_'); | |
| 1290 | $bBold = ($iBold >= 0x2BC)? 1: 0; | |
| 1291 | $bItalic = ($iAttr & 0x02)? 1: 0; | |
| 1292 | $bStrikeout = ($iAttr & 0x08)? 1: 0; | |
| 1293 | $bUnderline = ($iUnderline)? 1: 0; | |
| 1294 | } | |
| 1295 | else { | |
| 1296 | ($iHeight, $iAttr) = unpack("v2", $sWk); | |
| 1297 | $iCIdx = undef; | |
| 1298 | $iSuper = 0; | |
| 1299 | ||
| 1300 | $bBold = ($iAttr & 0x01)? 1: 0; | |
| 1301 | $bItalic = ($iAttr & 0x02)? 1: 0; | |
| 1302 | $bUnderline = ($iAttr & 0x04)? 1: 0; | |
| 1303 | $bStrikeout = ($iAttr & 0x08)? 1: 0; | |
| 1304 | ||
| 1305 | $sFntName = substr($sWk, 5, unpack("c", substr($sWk, 4, 1))); | |
| 1306 | } | |
| 1307 | push @{$oBook->{Font}}, | |
| 1308 | Spreadsheet::ParseExcel::Font->new( | |
| 1309 | Height => $iHeight / 20.0, | |
| 1310 | Attr => $iAttr, | |
| 1311 | Color => $iCIdx, | |
| 1312 | Super => $iSuper, | |
| 1313 | UnderlineStyle => $iUnderline, | |
| 1314 | Name => $sFntName, | |
| 1315 | ||
| 1316 | Bold => $bBold, | |
| 1317 | Italic => $bItalic, | |
| 1318 | Underline => $bUnderline, | |
| 1319 | Strikeout => $bStrikeout, | |
| 1320 | ); | |
| 1321 | #Skip Font[4] | |
| 1322 | push @{$oBook->{Font}}, {} if(scalar(@{$oBook->{Font}}) == 4); | |
| 1323 | ||
| 1324 | } | |
| 1325 | #------------------------------------------------------------------------------ | |
| 1326 | # _subBoundSheet (for Spreadsheet::ParseExcel): DK: P307 | |
| 1327 | #------------------------------------------------------------------------------ | |
| 1328 | sub _subBoundSheet($$$$) | |
| 1329 | { | |
| 1330 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 1331 | my($iPos, $iGr, $iKind) = unpack("Lc2", $sWk); | |
| 1332 | $iKind &= 0x0F; | |
| 1333 | return if(($iKind != 0x00) && ($iKind != 0x01)); | |
| 1334 | ||
| 1335 | if($oBook->{BIFFVersion} >= verBIFF8) { | |
| 1336 | my($iSize, $iUni) = unpack("cc", substr($sWk, 6, 2)); | |
| 1337 | my $sWsName = substr($sWk, 8); | |
| 1338 | if($iUni & 0x01) { | |
| 1339 | _SwapForUnicode(\$sWsName); | |
| 1340 | $sWsName = $oBook->{FmtClass}->TextFmt($sWsName, 'ucs2'); | |
| 1341 | } | |
| 1342 | $oBook->{Worksheet}[$oBook->{SheetCount}] = | |
| 1343 | new Spreadsheet::ParseExcel::Worksheet( | |
| 1344 | Name => $sWsName, | |
| 1345 | Kind => $iKind, | |
| 1346 | _Pos => $iPos, | |
| 1347 | _Book => $oBook, | |
| 1348 | _SheetNo => $oBook->{SheetCount}, | |
| 1349 | ); | |
| 1350 | } | |
| 1351 | else { | |
| 1352 | $oBook->{Worksheet}[$oBook->{SheetCount}] = | |
| 1353 | new Spreadsheet::ParseExcel::Worksheet( | |
| 1354 | Name => $oBook->{FmtClass}->TextFmt(substr($sWk, 7), '_native_'), | |
| 1355 | Kind => $iKind, | |
| 1356 | _Pos => $iPos, | |
| 1357 | _Book => $oBook, | |
| 1358 | _SheetNo => $oBook->{SheetCount}, | |
| 1359 | ); | |
| 1360 | } | |
| 1361 | $oBook->{SheetCount}++; | |
| 1362 | } | |
| 1363 | #------------------------------------------------------------------------------ | |
| 1364 | # _subHeader (for Spreadsheet::ParseExcel) DK: P340 | |
| 1365 | #------------------------------------------------------------------------------ | |
| 1366 | sub _subHeader($$$$) | |
| 1367 | { | |
| 1368 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 1369 | return undef unless(defined $oBook->{_CurSheet}); | |
| 1370 | my $sW; | |
| 1371 | #BIFF8 | |
| 1372 | if($oBook->{BIFFVersion} >= verBIFF8) { | |
| 1373 | $sW = _convBIFF8String($oBook, $sWk); | |
| 1374 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{Header} = | |
| 1375 | ($sW eq "\x00")? undef : $sW; | |
| 1376 | } | |
| 1377 | #Before BIFF8 | |
| 1378 | else { | |
| 1379 | my($iLen) = unpack("c", $sWk); | |
| 1380 | $sW = $oBook->{FmtClass}->TextFmt(substr($sWk, 1, $iLen), '_native_'); | |
| 1381 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{Header} = | |
| 1382 | ($sW eq "\x00\x00\x00")? undef : $sW; | |
| 1383 | } | |
| 1384 | } | |
| 1385 | #------------------------------------------------------------------------------ | |
| 1386 | # _subFooter (for Spreadsheet::ParseExcel) DK: P335 | |
| 1387 | #------------------------------------------------------------------------------ | |
| 1388 | sub _subFooter($$$$) | |
| 1389 | { | |
| 1390 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 1391 | return undef unless(defined $oBook->{_CurSheet}); | |
| 1392 | my $sW; | |
| 1393 | #BIFF8 | |
| 1394 | if($oBook->{BIFFVersion} >= verBIFF8) { | |
| 1395 | $sW = _convBIFF8String($oBook, $sWk); | |
| 1396 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{Footer} = | |
| 1397 | ($sW eq "\x00")? undef : $sW; | |
| 1398 | } | |
| 1399 | #Before BIFF8 | |
| 1400 | else { | |
| 1401 | my($iLen) = unpack("c", $sWk); | |
| 1402 | $sW = $oBook->{FmtClass}->TextFmt(substr($sWk, 1, $iLen), '_native_'); | |
| 1403 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{Footer} = | |
| 1404 | ($sW eq "\x00\x00\x00")? undef : $sW; | |
| 1405 | } | |
| 1406 | } | |
| 1407 | #------------------------------------------------------------------------------ | |
| 1408 | # _subHPageBreak (for Spreadsheet::ParseExcel) DK: P341 | |
| 1409 | #------------------------------------------------------------------------------ | |
| 1410 | sub _subHPageBreak($$$$) | |
| 1411 | { | |
| 1412 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 1413 | my @aBreak; | |
| 1414 | my $iCnt = unpack("v", $sWk); | |
| 1415 | ||
| 1416 | return undef unless(defined $oBook->{_CurSheet}); | |
| 1417 | #BIFF8 | |
| 1418 | if($oBook->{BIFFVersion} >= verBIFF8) { | |
| 1419 | for(my $i=0;$i<$iCnt;$i++) { | |
| 1420 | my($iRow, $iColB, $iColE) = | |
| 1421 | unpack('v3', substr($sWk, 2 + $i*6, 6)); | |
| 1422 | # push @aBreak, [$iRow, $iColB, $iColE]; | |
| 1423 | push @aBreak, $iRow; | |
| 1424 | } | |
| 1425 | } | |
| 1426 | #Before BIFF8 | |
| 1427 | else { | |
| 1428 | for(my $i=0;$i<$iCnt;$i++) { | |
| 1429 | my($iRow) = | |
| 1430 | unpack('v', substr($sWk, 2 + $i*2, 2)); | |
| 1431 | push @aBreak, $iRow; | |
| 1432 | # push @aBreak, [$iRow, 0, 255]; | |
| 1433 | } | |
| 1434 | } | |
| 1435 | @aBreak = sort {$a <=> $b} @aBreak; | |
| 1436 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{HPageBreak} = \@aBreak; | |
| 1437 | } | |
| 1438 | #------------------------------------------------------------------------------ | |
| 1439 | # _subVPageBreak (for Spreadsheet::ParseExcel) DK: P447 | |
| 1440 | #------------------------------------------------------------------------------ | |
| 1441 | sub _subVPageBreak($$$$) | |
| 1442 | { | |
| 1443 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 1444 | return undef unless(defined $oBook->{_CurSheet}); | |
| 1445 | ||
| 1446 | my @aBreak; | |
| 1447 | my $iCnt = unpack("v", $sWk); | |
| 1448 | #BIFF8 | |
| 1449 | if($oBook->{BIFFVersion} >= verBIFF8) { | |
| 1450 | for(my $i=0;$i<$iCnt;$i++) { | |
| 1451 | my($iCol, $iRowB, $iRowE) = | |
| 1452 | unpack('v3', substr($sWk, 2 + $i*6, 6)); | |
| 1453 | push @aBreak, $iCol; | |
| 1454 | # push @aBreak, [$iCol, $iRowB, $iRowE]; | |
| 1455 | } | |
| 1456 | } | |
| 1457 | #Before BIFF8 | |
| 1458 | else { | |
| 1459 | for(my $i=0;$i<$iCnt;$i++) { | |
| 1460 | my($iCol) = | |
| 1461 | unpack('v', substr($sWk, 2 + $i*2, 2)); | |
| 1462 | push @aBreak, $iCol; | |
| 1463 | # push @aBreak, [$iCol, 0, 65535]; | |
| 1464 | } | |
| 1465 | } | |
| 1466 | @aBreak = sort {$a <=> $b} @aBreak; | |
| 1467 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{VPageBreak} = \@aBreak; | |
| 1468 | } | |
| 1469 | #------------------------------------------------------------------------------ | |
| 1470 | # _subMergin (for Spreadsheet::ParseExcel) DK: P306, 345, 400, 440 | |
| 1471 | #------------------------------------------------------------------------------ | |
| 1472 | sub _subMergin($$$$) | |
| 1473 | { | |
| 1474 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 1475 | return undef unless(defined $oBook->{_CurSheet}); | |
| 1476 | ||
| 1477 | my $dWk = _convDval(substr($sWk, 0, 8)) * 127 / 50; | |
| 1478 | if($bOp == 0x26) { | |
| 1479 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{LeftMergin} = $dWk; | |
| 1480 | } | |
| 1481 | elsif($bOp == 0x27) { | |
| 1482 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{RightMergin} = $dWk; | |
| 1483 | } | |
| 1484 | elsif($bOp == 0x28) { | |
| 1485 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{TopMergin} = $dWk; | |
| 1486 | } | |
| 1487 | elsif($bOp == 0x29) { | |
| 1488 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{BottomMergin} = $dWk; | |
| 1489 | } | |
| 1490 | } | |
| 1491 | #------------------------------------------------------------------------------ | |
| 1492 | # _subHcenter (for Spreadsheet::ParseExcel) DK: P340 | |
| 1493 | #------------------------------------------------------------------------------ | |
| 1494 | sub _subHcenter($$$$) | |
| 1495 | { | |
| 1496 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 1497 | return undef unless(defined $oBook->{_CurSheet}); | |
| 1498 | ||
| 1499 | my $iWk = unpack("v", $sWk); | |
| 1500 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{HCenter} = $iWk; | |
| 1501 | ||
| 1502 | } | |
| 1503 | #------------------------------------------------------------------------------ | |
| 1504 | # _subVcenter (for Spreadsheet::ParseExcel) DK: P447 | |
| 1505 | #------------------------------------------------------------------------------ | |
| 1506 | sub _subVcenter($$$$) | |
| 1507 | { | |
| 1508 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 1509 | return undef unless(defined $oBook->{_CurSheet}); | |
| 1510 | ||
| 1511 | my $iWk = unpack("v", $sWk); | |
| 1512 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{VCenter} = $iWk; | |
| 1513 | } | |
| 1514 | #------------------------------------------------------------------------------ | |
| 1515 | # _subPrintGridlines (for Spreadsheet::ParseExcel) DK: P397 | |
| 1516 | #------------------------------------------------------------------------------ | |
| 1517 | sub _subPrintGridlines($$$$) | |
| 1518 | { | |
| 1519 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 1520 | return undef unless(defined $oBook->{_CurSheet}); | |
| 1521 | ||
| 1522 | my $iWk = unpack("v", $sWk); | |
| 1523 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{PrintGrid} = $iWk; | |
| 1524 | ||
| 1525 | } | |
| 1526 | #------------------------------------------------------------------------------ | |
| 1527 | # _subPrintHeaders (for Spreadsheet::ParseExcel) DK: P397 | |
| 1528 | #------------------------------------------------------------------------------ | |
| 1529 | sub _subPrintHeaders($$$$) | |
| 1530 | { | |
| 1531 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 1532 | return undef unless(defined $oBook->{_CurSheet}); | |
| 1533 | ||
| 1534 | my $iWk = unpack("v", $sWk); | |
| 1535 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{PrintHeaders} = $iWk; | |
| 1536 | } | |
| 1537 | #------------------------------------------------------------------------------ | |
| 1538 | # _subSETUP (for Spreadsheet::ParseExcel) DK: P409 | |
| 1539 | #------------------------------------------------------------------------------ | |
| 1540 | sub _subSETUP($$$$) | |
| 1541 | { | |
| 1542 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 1543 | return undef unless(defined $oBook->{_CurSheet}); | |
| 1544 | ||
| 1545 | my $oWkS = $oBook->{Worksheet}[$oBook->{_CurSheet}]; | |
| 1546 | my $iGrBit; | |
| 1547 | ||
| 1548 | ($oWkS->{PaperSize}, | |
| 1549 | $oWkS->{Scale} , | |
| 1550 | $oWkS->{PageStart}, | |
| 1551 | $oWkS->{FitWidth} , | |
| 1552 | $oWkS->{FitHeight}, | |
| 1553 | $iGrBit, | |
| 1554 | $oWkS->{Res}, | |
| 1555 | $oWkS->{VRes},) = unpack('v8', $sWk); | |
| 1556 | ||
| 1557 | $oWkS->{HeaderMergin} = _convDval(substr($sWk, 16, 8)) * 127 / 50; | |
| 1558 | $oWkS->{FooterMergin} = _convDval(substr($sWk, 24, 8)) * 127 / 50; | |
| 1559 | $oWkS->{Copis}= unpack('v2', substr($sWk, 32, 2)); | |
| 1560 | $oWkS->{LeftToRight}= (($iGrBit & 0x01)? 1: 0); | |
| 1561 | $oWkS->{Landscape} = (($iGrBit & 0x02)? 1: 0); | |
| 1562 | $oWkS->{NoPls} = (($iGrBit & 0x04)? 1: 0); | |
| 1563 | $oWkS->{NoColor} = (($iGrBit & 0x08)? 1: 0); | |
| 1564 | $oWkS->{Draft} = (($iGrBit & 0x10)? 1: 0); | |
| 1565 | $oWkS->{Notes} = (($iGrBit & 0x20)? 1: 0); | |
| 1566 | $oWkS->{NoOrient} = (($iGrBit & 0x40)? 1: 0); | |
| 1567 | $oWkS->{UsePage} = (($iGrBit & 0x80)? 1: 0); | |
| 1568 | } | |
| 1569 | #------------------------------------------------------------------------------ | |
| 1570 | # _subName (for Spreadsheet::ParseExcel) DK: P350 | |
| 1571 | #------------------------------------------------------------------------------ | |
| 1572 | sub _subName($$$$) | |
| 1573 | { | |
| 1574 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 1575 | my($iGrBit, | |
| 1576 | $cKey, $cCh, | |
| 1577 | $iCce, $ixAls, $iTab, | |
| 1578 | $cchCust, $cchDsc, $cchHep, $cchStatus) = unpack('vc2v3c4', $sWk); | |
| 1579 | #Builtin Name + Length == 1 | |
| 1580 | if(($iGrBit & 0x20) && ($cCh == 1)) { | |
| 1581 | #BIFF8 | |
| 1582 | if($oBook->{BIFFVersion} >= verBIFF8) { | |
| 1583 | my $iName = unpack('n', substr($sWk, 14 )); | |
| 1584 | my $iSheet = unpack('v', substr($sWk, 8 )) - 1; | |
| 1585 | if($iName == 6) { #PrintArea | |
| 1586 | my($iSheetW, $raArea) = _ParseNameArea(substr($sWk, 16)); | |
| 1587 | $oBook->{PrintArea}[$iSheet] = $raArea; | |
| 1588 | } | |
| 1589 | elsif($iName == 7) { #Title | |
| 1590 | my($iSheetW, $raArea) = _ParseNameArea(substr($sWk, 16)); | |
| 1591 | my @aTtlR = (); | |
| 1592 | my @aTtlC = (); | |
| 1593 | foreach my $raI (@$raArea) { | |
| 1594 | if($raI->[3] == 0xFF) { #Row Title | |
| 1595 | push @aTtlR, [$raI->[0], $raI->[2] ]; | |
| 1596 | } | |
| 1597 | else { #Col Title | |
| 1598 | push @aTtlC, [$raI->[1], $raI->[3] ]; | |
| 1599 | } | |
| 1600 | } | |
| 1601 | $oBook->{PrintTitle}[$iSheet] = {Row => \@aTtlR, Column => \@aTtlC}; | |
| 1602 | } | |
| 1603 | } | |
| 1604 | else { | |
| 1605 | my $iName = unpack('c', substr($sWk, 14 )); | |
| 1606 | if($iName == 6) { #PrintArea | |
| 1607 | my($iSheet, $raArea) = _ParseNameArea95(substr($sWk, 15)); | |
| 1608 | $oBook->{PrintArea}[$iSheet] = $raArea; | |
| 1609 | } | |
| 1610 | elsif($iName == 7) { #Title | |
| 1611 | my($iSheet, $raArea) = _ParseNameArea95(substr($sWk, 15)); | |
| 1612 | my @aTtlR = (); | |
| 1613 | my @aTtlC = (); | |
| 1614 | foreach my $raI (@$raArea) { | |
| 1615 | if($raI->[3] == 0xFF) { #Row Title | |
| 1616 | push @aTtlR, [$raI->[0], $raI->[2] ]; | |
| 1617 | } | |
| 1618 | else { #Col Title | |
| 1619 | push @aTtlC, [$raI->[1], $raI->[3] ]; | |
| 1620 | } | |
| 1621 | } | |
| 1622 | $oBook->{PrintTitle}[$iSheet] = {Row => \@aTtlR, Column => \@aTtlC}; | |
| 1623 | } | |
| 1624 | } | |
| 1625 | } | |
| 1626 | } | |
| 1627 | #------------------------------------------------------------------------------ | |
| 1628 | # ParseNameArea (for Spreadsheet::ParseExcel) DK: 494 (ptgAread3d) | |
| 1629 | #------------------------------------------------------------------------------ | |
| 1630 | sub _ParseNameArea($) { | |
| 1631 | my ($sObj) =@_; | |
| 1632 | my ($iOp); | |
| 1633 | my @aRes = (); | |
| 1634 | $iOp = unpack('C', $sObj); | |
| 1635 | my $iSheet; | |
| 1636 | if($iOp == 0x3b) { | |
| 1637 | my($iWkS, $iRs, $iRe, $iCs, $iCe) = | |
| 1638 | unpack('v5', substr($sObj, 1)); | |
| 1639 | $iSheet = $iWkS; | |
| 1640 | push @aRes, [$iRs, $iCs, $iRe, $iCe]; | |
| 1641 | } | |
| 1642 | elsif($iOp == 0x29) { | |
| 1643 | my $iLen = unpack('v', substr($sObj, 1, 2)); | |
| 1644 | my $iSt = 0; | |
| 1645 | while($iSt < $iLen) { | |
| 1646 | my($iOpW, $iWkS, $iRs, $iRe, $iCs, $iCe) = | |
| 1647 | unpack('cv5', substr($sObj, $iSt+3, 11)); | |
| 1648 | ||
| 1649 | if($iOpW == 0x3b) { | |
| 1650 | $iSheet = $iWkS; | |
| 1651 | push @aRes, [$iRs, $iCs, $iRe, $iCe]; | |
| 1652 | } | |
| 1653 | ||
| 1654 | if($iSt==0) { | |
| 1655 | $iSt += 11; | |
| 1656 | } | |
| 1657 | else { | |
| 1658 | $iSt += 12; #Skip 1 byte; | |
| 1659 | } | |
| 1660 | } | |
| 1661 | } | |
| 1662 | return ($iSheet, \@aRes); | |
| 1663 | } | |
| 1664 | #------------------------------------------------------------------------------ | |
| 1665 | # ParseNameArea95 (for Spreadsheet::ParseExcel) DK: 494 (ptgAread3d) | |
| 1666 | #------------------------------------------------------------------------------ | |
| 1667 | sub _ParseNameArea95($) { | |
| 1668 | my ($sObj) =@_; | |
| 1669 | my ($iOp); | |
| 1670 | my @aRes = (); | |
| 1671 | $iOp = unpack('C', $sObj); | |
| 1672 | my $iSheet; | |
| 1673 | if($iOp == 0x3b) { | |
| 1674 | $iSheet = unpack('v', substr($sObj, 11, 2)); | |
| 1675 | my($iRs, $iRe, $iCs, $iCe) = | |
| 1676 | unpack('v2C2', substr($sObj, 15, 6)); | |
| 1677 | push @aRes, [$iRs, $iCs, $iRe, $iCe]; | |
| 1678 | } | |
| 1679 | elsif($iOp == 0x29) { | |
| 1680 | my $iLen = unpack('v', substr($sObj, 1, 2)); | |
| 1681 | my $iSt = 0; | |
| 1682 | while($iSt < $iLen) { | |
| 1683 | my $iOpW = unpack('c', substr($sObj, $iSt+3, 6)); | |
| 1684 | $iSheet = unpack('v', substr($sObj, $iSt+14, 2)); | |
| 1685 | my($iRs, $iRe, $iCs, $iCe) = | |
| 1686 | unpack('v2C2', substr($sObj, $iSt+18, 6)); | |
| 1687 | push @aRes, [$iRs, $iCs, $iRe, $iCe] if($iOpW == 0x3b); | |
| 1688 | ||
| 1689 | if($iSt==0) { | |
| 1690 | $iSt += 21; | |
| 1691 | } | |
| 1692 | else { | |
| 1693 | $iSt += 22; #Skip 1 byte; | |
| 1694 | } | |
| 1695 | } | |
| 1696 | } | |
| 1697 | return ($iSheet, \@aRes); | |
| 1698 | } | |
| 1699 | #------------------------------------------------------------------------------ | |
| 1700 | # _subBOOL (for Spreadsheet::ParseExcel) DK: P452 | |
| 1701 | #------------------------------------------------------------------------------ | |
| 1702 | sub _subWSBOOL($$$$) | |
| 1703 | { | |
| 1704 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 1705 | return undef unless(defined $oBook->{_CurSheet}); | |
| 1706 | ||
| 1707 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{PageFit} = | |
| 1708 | ((unpack('v', $sWk) & 0x100)? 1: 0); | |
| 1709 | } | |
| 1710 | #------------------------------------------------------------------------------ | |
| 1711 | # _subMergeArea (for Spreadsheet::ParseExcel) DK: (Not) | |
| 1712 | #------------------------------------------------------------------------------ | |
| 1713 | sub _subMergeArea($$$$) | |
| 1714 | { | |
| 1715 | my($oBook, $bOp, $bLen, $sWk) = @_; | |
| 1716 | return undef unless(defined $oBook->{_CurSheet}); | |
| 1717 | ||
| 1718 | my $iCnt = unpack("v", $sWk); | |
| 1719 | my $oWkS = $oBook->{Worksheet}[$oBook->{_CurSheet}]; | |
| 1720 | $oWkS->{MergedArea} = [] unless(defined $oWkS->{MergedArea}); | |
| 1721 | for(my $i=0; $i < $iCnt; $i++) { | |
| 1722 | my($iRs, $iRe, $iCs, $iCe) = unpack('v4', substr($sWk, $i*8 + 2, 8)); | |
| 1723 | for(my $iR=$iRs;$iR<=$iRe;$iR++) { | |
| 1724 | for(my $iC=$iCs;$iC<=$iCe;$iC++) { | |
| 1725 | $oWkS->{Cells}[$iR][$iC] ->{Merged} = 1 | |
| 1726 | if(defined $oWkS->{Cells}[$iR][$iC] ); | |
| 1727 | } | |
| 1728 | } | |
| 1729 | push @{$oWkS->{MergedArea}}, [$iRs, $iCs, $iRe, $iCe]; | |
| 1730 | } | |
| 1731 | } | |
| 1732 | #------------------------------------------------------------------------------ | |
| 1733 | # DecodeBoolErr (for Spreadsheet::ParseExcel) DK: P306 | |
| 1734 | #------------------------------------------------------------------------------ | |
| 1735 | sub DecodeBoolErr($$) | |
| 1736 | { | |
| 1737 | my($iVal, $iFlg) = @_; | |
| 1738 | if($iFlg) { # ERROR | |
| 1739 | if($iVal == 0x00) { | |
| 1740 | return "#NULL!"; | |
| 1741 | } | |
| 1742 | elsif($iVal == 0x07) { | |
| 1743 | return "#DIV/0!"; | |
| 1744 | } | |
| 1745 | elsif($iVal == 0x0F) { | |
| 1746 | return "#VALUE!"; | |
| 1747 | } | |
| 1748 | elsif($iVal == 0x17) { | |
| 1749 | return "#REF!"; | |
| 1750 | } | |
| 1751 | elsif($iVal == 0x1D) { | |
| 1752 | return "#NAME?"; | |
| 1753 | } | |
| 1754 | elsif($iVal == 0x24) { | |
| 1755 | return "#NUM!"; | |
| 1756 | } | |
| 1757 | elsif($iVal == 0x2A) { | |
| 1758 | return "#N/A!"; | |
| 1759 | } | |
| 1760 | else { | |
| 1761 | return "#ERR"; | |
| 1762 | } | |
| 1763 | } | |
| 1764 | else { | |
| 1765 | return ($iVal)? "TRUE" : "FALSE"; | |
| 1766 | } | |
| 1767 | } | |
| 1768 | #------------------------------------------------------------------------------ | |
| 1769 | # _UnpackRKRec (for Spreadsheet::ParseExcel) DK:P 401 | |
| 1770 | #------------------------------------------------------------------------------ | |
| 1771 | sub _UnpackRKRec($) { | |
| 1772 | my($sArg) = @_; | |
| 1773 | ||
| 1774 | my $iF = unpack('v', substr($sArg, 0, 2)); | |
| 1775 | ||
| 1776 | my $lWk = substr($sArg, 2, 4); | |
| 1777 | my $sWk = pack("c4", reverse(unpack("c4", $lWk))); | |
| 1778 | my $iPtn = unpack("c",substr($sWk, 3, 1)) & 0x03; | |
| 1779 | if($iPtn == 0) { | |
| 1780 | return ($iF, unpack("d", ($BIGENDIAN)? $sWk . "\0\0\0\0": "\0\0\0\0". $lWk)); | |
| 1781 | } | |
| 1782 | elsif($iPtn == 1) { | |
| 1783 | substr($sWk, 3, 1) &= pack('c', unpack("c",substr($sWk, 3, 1)) & 0xFC); | |
| 1784 | substr($lWk, 0, 1) &= pack('c', unpack("c",substr($lWk, 0, 1)) & 0xFC); | |
| 1785 | return ($iF, unpack("d", ($BIGENDIAN)? $sWk . "\0\0\0\0": "\0\0\0\0". $lWk)/ 100); | |
| 1786 | } | |
| 1787 | elsif($iPtn == 2) { | |
| 1788 | my $sUB = unpack("B32", $sWk); | |
| 1789 | my $sWkLB = pack("B32", (substr($sUB, 0, 1) x 2) . | |
| 1790 | substr($sUB, 0, 30)); | |
| 1791 | my $sWkL = ($BIGENDIAN)? $sWkLB: pack("c4", reverse(unpack("c4", $sWkLB))); | |
| 1792 | return ($iF, unpack("i", $sWkL)); | |
| 1793 | } | |
| 1794 | else { | |
| 1795 | my $sUB = unpack("B32", $sWk); | |
| 1796 | my $sWkLB = pack("B32", (substr($sUB, 0, 1) x 2) . | |
| 1797 | substr($sUB, 0, 30)); | |
| 1798 | my $sWkL = ($BIGENDIAN)? $sWkLB: pack("c4", reverse(unpack("c4", $sWkLB))); | |
| 1799 | return ($iF, unpack("i", $sWkL) / 100); | |
| 1800 | } | |
| 1801 | } | |
| 1802 | #------------------------------------------------------------------------------ | |
| 1803 | # _subStrWk (for Spreadsheet::ParseExcel) DK:P280 .. | |
| 1804 | #------------------------------------------------------------------------------ | |
| 1805 | sub _subStrWk($$;$) | |
| 1806 | { | |
| 1807 | my($oBook, $sWk, $fCnt) = @_; | |
| 1808 | ||
| 1809 | #1. Continue | |
| 1810 | if(defined($fCnt)) { | |
| 1811 | #1.1 Before No Data No | |
| 1812 | if($oBook->{StrBuff} eq '') { # | |
| 1813 | #print "CONT NO DATA\n"; | |
| 1814 | #print "DATA:", unpack('H30', $oBook->{StrBuff}), " PRE:$oBook->{_PrevCond}\n"; | |
| 1815 | $oBook->{StrBuff} .= $sWk; | |
| 1816 | } | |
| 1817 | #1.1 No PrevCond | |
| 1818 | elsif(!(defined($oBook->{_PrevCond}))) { | |
| 1819 | #print "NO PREVCOND\n"; | |
| 1820 | $oBook->{StrBuff} .= substr($sWk, 1); | |
| 1821 | } | |
| 1822 | else { | |
| 1823 | #print "CONT\n"; | |
| 1824 | my $iCnt1st = ord($sWk); # 1st byte of Continue may be a GR byte | |
| 1825 | my($iStP, $iLenS) = @{$oBook->{_PrevInfo}}; | |
| 1826 | my $iLenB = length($oBook->{StrBuff}); | |
| 1827 | ||
| 1828 | #1.1 Not in String | |
| 1829 | if($iLenB >= ($iStP + $iLenS)) { | |
| 1830 | #print "NOT STR\n"; | |
| 1831 | $oBook->{StrBuff} .= $sWk; | |
| 1832 | # $oBook->{StrBuff} .= substr($sWk, 1); | |
| 1833 | } | |
| 1834 | #1.2 Same code (Unicode or ASCII) | |
| 1835 | elsif(($oBook->{_PrevCond} & 0x01) == ($iCnt1st & 0x01)) { | |
| 1836 | #print "SAME\n"; | |
| 1837 | $oBook->{StrBuff} .= substr($sWk, 1); | |
| 1838 | } | |
| 1839 | else { | |
| 1840 | #1.3 Diff code (Unicode or ASCII) | |
| 1841 | my $iDiff = ($iStP + $iLenS) - $iLenB; | |
| 1842 | if($iCnt1st & 0x01) { | |
| 1843 | #print "DIFF ASC $iStP $iLenS $iLenB DIFF:$iDiff\n"; | |
| 1844 | #print "BEF:", unpack("H6", $oBook->{StrBuff}), "\n"; | |
| 1845 | my ($iDum, $iGr) =unpack('vc', $oBook->{StrBuff}); | |
| 1846 | substr($oBook->{StrBuff}, 2, 1) = pack('c', $iGr | 0x01); | |
| 1847 | #print "AFT:", unpack("H6", $oBook->{StrBuff}), "\n"; | |
| 1848 | for(my $i = ($iLenB-$iStP); $i >=1; $i--) { | |
| 1849 | substr($oBook->{StrBuff}, $iStP+$i, 0) = "\x00"; | |
| 1850 | } | |
| 1851 | } | |
| 1852 | else { | |
| 1853 | #print "DIFF UNI:", $oBook->{_PrevCond}, ":", $iCnt1st, " DIFF:$iDiff\n"; | |
| 1854 | for(my $i = ($iDiff/2); $i>=1;$i--) { | |
| 1855 | substr($sWk, $i+1, 0) = "\x00"; | |
| 1856 | } | |
| 1857 | } | |
| 1858 | $oBook->{StrBuff} .= substr($sWk, 1); | |
| 1859 | } | |
| 1860 | } | |
| 1861 | } | |
| 1862 | else { | |
| 1863 | #2. Saisho | |
| 1864 | $oBook->{StrBuff} .= $sWk; | |
| 1865 | } | |
| 1866 | #print " AFT2:", unpack("H60", $oBook->{StrBuff}), "\n"; | |
| 1867 | ||
| 1868 | $oBook->{_PrevCond} = undef; | |
| 1869 | $oBook->{_PrevInfo} = undef; | |
| 1870 | ||
| 1871 | while(length($oBook->{StrBuff}) >= 4) { | |
| 1872 | my ( $raBuff, $iLen, $iStPos, $iLenS) = _convBIFF8String($oBook, $oBook->{StrBuff}, 1); | |
| 1873 | #No Code Convert | |
| 1874 | if(defined($raBuff->[0])) { | |
| 1875 | push @{$oBook->{PkgStr}}, | |
| 1876 | { | |
| 1877 | Text => $raBuff->[0], | |
| 1878 | Unicode => $raBuff->[1], | |
| 1879 | Rich => $raBuff->[2], | |
| 1880 | Ext => $raBuff->[3], | |
| 1881 | }; | |
| 1882 | $oBook->{StrBuff} = substr($oBook->{StrBuff}, $iLen); | |
| 1883 | } | |
| 1884 | else { | |
| 1885 | $oBook->{_PrevCond} = $raBuff->[1]; | |
| 1886 | $oBook->{_PrevInfo} = [$iStPos, $iLenS]; | |
| 1887 | last; | |
| 1888 | } | |
| 1889 | } | |
| 1890 | } | |
| 1891 | #------------------------------------------------------------------------------ | |
| 1892 | # _SwapForUnicode (for Spreadsheet::ParseExcel) | |
| 1893 | #------------------------------------------------------------------------------ | |
| 1894 | sub _SwapForUnicode(\$) | |
| 1895 | { | |
| 1896 | my($sObj) = @_; | |
| 1897 | # for(my $i = 0; $i<length($$sObj); $i+=2){ | |
| 1898 | for(my $i = 0; $i<(int (length($$sObj) / 2) * 2); $i+=2) { | |
| 1899 | my $sIt = substr($$sObj, $i, 1); | |
| 1900 | substr($$sObj, $i, 1) = substr($$sObj, $i+1, 1); | |
| 1901 | substr($$sObj, $i+1, 1) = $sIt; | |
| 1902 | } | |
| 1903 | } | |
| 1904 | #------------------------------------------------------------------------------ | |
| 1905 | # _NewCell (for Spreadsheet::ParseExcel) | |
| 1906 | #------------------------------------------------------------------------------ | |
| 1907 | sub _NewCell($$$%) | |
| 1908 | { | |
| 1909 | my($oBook, $iR, $iC, %rhKey)=@_; | |
| 1910 | my($sWk, $iLen); | |
| 1911 | return undef unless(defined $oBook->{_CurSheet}); | |
| 1912 | ||
| 1913 | my $oCell = | |
| 1914 | Spreadsheet::ParseExcel::Cell->new( | |
| 1915 | Val => $rhKey{Val}, | |
| 1916 | FormatNo=> $rhKey{FormatNo}, | |
| 1917 | Format => $rhKey{Format}, | |
| 1918 | Code => $rhKey{Code}, | |
| 1919 | Type => $oBook->{FmtClass}->ChkType( | |
| 1920 | $rhKey{Numeric}, | |
| 1921 | $rhKey{Format}->{FmtIdx}), | |
| 1922 | ); | |
| 1923 | $oCell->{_Kind} = $rhKey{Kind}; | |
| 1924 | $oCell->{_Value} = $oBook->{FmtClass}->ValFmt($oCell, $oBook); | |
| 1925 | if($rhKey{Rich}) { | |
| 1926 | my @aRich = (); | |
| 1927 | my $sRich = $rhKey{Rich}; | |
| 1928 | for(my $iWk=0;$iWk<length($sRich); $iWk+=4) { | |
| 1929 | my($iPos, $iFnt) = unpack('v2', substr($sRich, $iWk)); | |
| 1930 | push @aRich, [$iPos, $oBook->{Font}[$iFnt]]; | |
| 1931 | } | |
| 1932 | $oCell->{Rich} = \@aRich; | |
| 1933 | } | |
| 1934 | ||
| 1935 | if(defined $_CellHandler) { | |
| 1936 | if(defined $_Object){ | |
| 1937 | no strict; | |
| 1938 | ref($_CellHandler) eq "CODE" ? | |
| 1939 | $_CellHandler->($_Object, $oBook, $oBook->{_CurSheet}, $iR, $iC, $oCell) : | |
| 1940 | $_CellHandler->callback($_Object, $oBook, $oBook->{_CurSheet}, $iR, $iC, $oCell); | |
| 1941 | } | |
| 1942 | else{ | |
| 1943 | $_CellHandler->($oBook, $oBook->{_CurSheet}, $iR, $iC, $oCell); | |
| 1944 | } | |
| 1945 | } | |
| 1946 | unless($_NotSetCell) { | |
| 1947 | $oBook->{Worksheet}[$oBook->{_CurSheet}]->{Cells}[$iR][$iC] | |
| 1948 | = $oCell; | |
| 1949 | } | |
| 1950 | return $oCell; | |
| 1951 | } | |
| 1952 | #------------------------------------------------------------------------------ | |
| 1953 | # ColorIdxToRGB (for Spreadsheet::ParseExcel) | |
| 1954 | #------------------------------------------------------------------------------ | |
| 1955 | sub ColorIdxToRGB($$){ | |
| 1956 | my($sPkg, $iIdx) = @_; | |
| 1957 | return ((defined $aColor[$iIdx])? $aColor[$iIdx] : $aColor[0]); | |
| 1958 | } | |
| 1959 | 1; | |
| 1960 | __END__ | |
| 1961 | ||
| 1962 | =head1 NAME | |
| 1963 | ||
| 1964 | Spreadsheet::ParseExcel - Get information from Excel file | |
| 1965 | ||
| 1966 | =head1 SYNOPSIS | |
| 1967 | ||
| 1968 | use strict; | |
| 1969 | use Spreadsheet::ParseExcel; | |
| 1970 | my $oExcel = new Spreadsheet::ParseExcel; | |
| 1971 | ||
| 1972 | #1.1 Normal Excel97 | |
| 1973 | my $oBook = $oExcel->Parse('Excel/Test97.xls'); | |
| 1974 | my($iR, $iC, $oWkS, $oWkC); | |
| 1975 | print "FILE :", $oBook->{File} , "\n"; | |
| 1976 | print "COUNT :", $oBook->{SheetCount} , "\n"; | |
| 1977 | print "AUTHOR:", $oBook->{Author} , "\n"; | |
| 1978 | for(my $iSheet=0; $iSheet < $oBook->{SheetCount} ; $iSheet++) { | |
| 1979 | $oWkS = $oBook->{Worksheet}[$iSheet]; | |
| 1980 | print "--------- SHEET:", $oWkS->{Name}, "\n"; | |
| 1981 | for(my $iR = $oWkS->{MinRow} ; | |
| 1982 | defined $oWkS->{MaxRow} && $iR <= $oWkS->{MaxRow} ; $iR++) { | |
| 1983 | for(my $iC = $oWkS->{MinCol} ; | |
| 1984 | defined $oWkS->{MaxCol} && $iC <= $oWkS->{MaxCol} ; $iC++) { | |
| 1985 | $oWkC = $oWkS->{Cells}[$iR][$iC]; | |
| 1986 | print "( $iR , $iC ) =>", $oWkC->Value, "\n" if($oWkC); # Formatted Value | |
| 1987 | print "( $iR , $iC ) =>", $oWkC->{Val}, "\n" if($oWkC); # Original Value | |
| 1988 | } | |
| 1989 | } | |
| 1990 | } | |
| 1991 | ||
| 1992 | I<new interface> | |
| 1993 | ||
| 1994 | use strict; | |
| 1995 | use Spreadsheet::ParseExcel; | |
| 1996 | my $oBook = | |
| 1997 | Spreadsheet::ParseExcel::Workbook->Parse('Excel/Test97.xls'); | |
| 1998 | my($iR, $iC, $oWkS, $oWkC); | |
| 1999 | foreach my $oWkS (@{$oBook->{Worksheet}}) { | |
| 2000 | print "--------- SHEET:", $oWkS->{Name}, "\n"; | |
| 2001 | for(my $iR = $oWkS->{MinRow} ; | |
| 2002 | defined $oWkS->{MaxRow} && $iR <= $oWkS->{MaxRow} ; $iR++) { | |
| 2003 | for(my $iC = $oWkS->{MinCol} ; | |
| 2004 | defined $oWkS->{MaxCol} && $iC <= $oWkS->{MaxCol} ; $iC++) { | |
| 2005 | $oWkC = $oWkS->{Cells}[$iR][$iC]; | |
| 2006 | print "( $iR , $iC ) =>", $oWkC->Value, "\n" if($oWkC); | |
| 2007 | } | |
| 2008 | } | |
| 2009 | } | |
| 2010 | ||
| 2011 | =head1 DESCRIPTION | |
| 2012 | ||
| 2013 | Spreadsheet::ParseExcel makes you to get information from Excel95, Excel97, Excel2000 file. | |
| 2014 | ||
| 2015 | =head2 Functions | |
| 2016 | ||
| 2017 | =over 4 | |
| 2018 | ||
| 2019 | =item new | |
| 2020 | ||
| 2021 | I<$oExcel> = new Spreadsheet::ParseExcel( | |
| 2022 | [ I<CellHandler> => \&subCellHandler, | |
| 2023 | I<NotSetCell> => undef | 1, | |
| 2024 | ]); | |
| 2025 | ||
| 2026 | Constructor. | |
| 2027 | ||
| 2028 | ||
| 2029 | =over 4 | |
| 2030 | ||
| 2031 | =item CellHandler I<(experimental)> | |
| 2032 | ||
| 2033 | specify callback function when a cell is detected. | |
| 2034 | ||
| 2035 | I<subCellHandler> gets arguments like below: | |
| 2036 | ||
| 2037 | sub subCellHandler (I<$oBook>, I<$iSheet>, I<$iRow>, I<$iCol>, I<$oCell>); | |
| 2038 | ||
| 2039 | B<CAUTION> : The atributes of Workbook may not be complete. | |
| 2040 | This function will be called almost order by rows and columns. | |
| 2041 | Take care B<almost>, I<not perfectly>. | |
| 2042 | ||
| 2043 | =item NotSetCell I<(experimental)> | |
| 2044 | ||
| 2045 | specify set or not cell values to Workbook object. | |
| 2046 | ||
| 2047 | =back | |
| 2048 | ||
| 2049 | =item Parse | |
| 2050 | ||
| 2051 | I<$oWorkbook> = $oParse->Parse(I<$sFileName> [, I<$oFmt>]); | |
| 2052 | ||
| 2053 | return L<"Workbook"> object. | |
| 2054 | if error occurs, returns undef. | |
| 2055 | ||
| 2056 | =over 4 | |
| 2057 | ||
| 2058 | =item I<$sFileName> | |
| 2059 | ||
| 2060 | name of the file to parse | |
| 2061 | ||
| 2062 | From 0.12 (with OLE::Storage_Lite v.0.06), | |
| 2063 | scalar reference of file contents (ex. \$sBuff) or | |
| 2064 | IO::Handle object (inclucdng IO::File etc.) are also available. | |
| 2065 | ||
| 2066 | =item I<$oFmt> | |
| 2067 | ||
| 2068 | L<"Formatter Class"> to format the value of cells. | |
| 2069 | ||
| 2070 | =back | |
| 2071 | ||
| 2072 | =item ColorIdxToRGB | |
| 2073 | ||
| 2074 | I<$sRGB> = $oParse->ColorIdxToRGB(I<$iColorIdx>); | |
| 2075 | ||
| 2076 | I<ColorIdxToRGB> returns RGB string corresponding to specified color index. | |
| 2077 | RGB string has 6 charcters, representing RGB hex value. (ex. red = 'FF0000') | |
| 2078 | ||
| 2079 | =back | |
| 2080 | ||
| 2081 | =head2 Workbook | |
| 2082 | ||
| 2083 | I<Spreadsheet::ParseExcel::Workbook> | |
| 2084 | ||
| 2085 | Workbook class has these methods : | |
| 2086 | ||
| 2087 | =over 4 | |
| 2088 | ||
| 2089 | =item Parse | |
| 2090 | ||
| 2091 | (class method) : same as Spreadsheet::ParseExcel | |
| 2092 | ||
| 2093 | =back | |
| 2094 | ||
| 2095 | =over 4 | |
| 2096 | ||
| 2097 | =item Worksheet | |
| 2098 | ||
| 2099 | I<$oWorksheet> = $oBook->Worksheet(I<$sName>); | |
| 2100 | ||
| 2101 | I<Worksheet> returns a Worksheet object with I<$sName> or undef. | |
| 2102 | If there is no worksheet with I<$sName> and I<$sName> contains only digits, | |
| 2103 | it returns a Worksheet object at that position. | |
| 2104 | ||
| 2105 | =back | |
| 2106 | ||
| 2107 | Workbook class has these properties : | |
| 2108 | ||
| 2109 | =over 4 | |
| 2110 | ||
| 2111 | =item File | |
| 2112 | ||
| 2113 | Name of the file | |
| 2114 | ||
| 2115 | =item Author | |
| 2116 | ||
| 2117 | Author of the file | |
| 2118 | ||
| 2119 | =item Flag1904 | |
| 2120 | ||
| 2121 | If this flag is on, date of the file count from 1904. | |
| 2122 | ||
| 2123 | =item Version | |
| 2124 | ||
| 2125 | Version of the file | |
| 2126 | ||
| 2127 | =item SheetCount | |
| 2128 | ||
| 2129 | Numbers of L<"Worksheet"> s in that Workbook | |
| 2130 | ||
| 2131 | =item Worksheet[SheetNo] | |
| 2132 | ||
| 2133 | Array of L<"Worksheet">s class | |
| 2134 | ||
| 2135 | =item PrintArea[SheetNo] | |
| 2136 | ||
| 2137 | Array of PrintArea array refs. | |
| 2138 | ||
| 2139 | Each PrintArea is : [ I<StartRow>, I<StartColumn>, I<EndRow>, I<EndColumn>] | |
| 2140 | ||
| 2141 | =item PrintTitle[SheetNo] | |
| 2142 | ||
| 2143 | Array of PrintTitle hash refs. | |
| 2144 | ||
| 2145 | Each PrintTitle is : | |
| 2146 | { Row => [I<StartRow>, I<EndRow>], | |
| 2147 | Column => [I<StartColumn>, I<EndColumn>]} | |
| 2148 | ||
| 2149 | =back | |
| 2150 | ||
| 2151 | =head2 Worksheet | |
| 2152 | ||
| 2153 | I<Spreadsheet::ParseExcel::Worksheet> | |
| 2154 | ||
| 2155 | Worksheet class has these methods: | |
| 2156 | ||
| 2157 | =over 4 | |
| 2158 | ||
| 2159 | =item Cell ( ROW, COL ) | |
| 2160 | ||
| 2161 | Return the Cell iobject at row ROW and column COL if | |
| 2162 | it is defined. Otherwise return undef. | |
| 2163 | ||
| 2164 | =item RowRange () | |
| 2165 | ||
| 2166 | Return a two-element list (MIN, MAX) containing the | |
| 2167 | minimum and maximum of defined rows in the worksheet | |
| 2168 | If there is no row defined MAX is smaller than MIN. | |
| 2169 | ||
| 2170 | =item ColRange () | |
| 2171 | ||
| 2172 | Return a two-element list (MIN, MAX) containing the | |
| 2173 | minimum and maximum of defined columns in the worksheet | |
| 2174 | If there is no row defined MAX is smaller than MIN. | |
| 2175 | ||
| 2176 | =back | |
| 2177 | ||
| 2178 | Worksheet class has these properties: | |
| 2179 | ||
| 2180 | =over 4 | |
| 2181 | ||
| 2182 | =item Name | |
| 2183 | ||
| 2184 | Name of that Worksheet | |
| 2185 | ||
| 2186 | =item DefRowHeight | |
| 2187 | ||
| 2188 | Default height of rows | |
| 2189 | ||
| 2190 | =item DefColWidth | |
| 2191 | ||
| 2192 | Default width of columns | |
| 2193 | ||
| 2194 | =item RowHeight[Row] | |
| 2195 | ||
| 2196 | Array of row height | |
| 2197 | ||
| 2198 | =item ColWidth[Col] | |
| 2199 | ||
| 2200 | Array of column width (undef means DefColWidth) | |
| 2201 | ||
| 2202 | =item Cells[Row][Col] | |
| 2203 | ||
| 2204 | Array of L<"Cell">s infomation in the worksheet | |
| 2205 | ||
| 2206 | =item Landscape | |
| 2207 | ||
| 2208 | Print in horizontal(0) or vertical (1). | |
| 2209 | ||
| 2210 | =item Scale | |
| 2211 | ||
| 2212 | Print scale. | |
| 2213 | ||
| 2214 | =item FitWidth | |
| 2215 | ||
| 2216 | Number of pages with fit in width. | |
| 2217 | ||
| 2218 | =item FitHeight | |
| 2219 | ||
| 2220 | Number of pages with fit in height. | |
| 2221 | ||
| 2222 | =item PageFit | |
| 2223 | ||
| 2224 | Print with fit (or not). | |
| 2225 | ||
| 2226 | =item PaperSize | |
| 2227 | ||
| 2228 | Papar size. The value is like below: | |
| 2229 | ||
| 2230 | Letter 1, LetterSmall 2, Tabloid 3 , | |
| 2231 | Ledger 4, Legal 5, Statement 6 , | |
| 2232 | Executive 7, A3 8, A4 9 , | |
| 2233 | A4Small 10, A5 11, B4 12 , | |
| 2234 | B5 13, Folio 14, Quarto 15 , | |
| 2235 | 10x14 16, 11x17 17, Note 18 , | |
| 2236 | Envelope9 19, Envelope10 20, Envelope11 21 , | |
| 2237 | Envelope12 22, Envelope14 23, Csheet 24 , | |
| 2238 | Dsheet 25, Esheet 26, EnvelopeDL 27 , | |
| 2239 | EnvelopeC5 28, EnvelopeC3 29, EnvelopeC4 30 , | |
| 2240 | EnvelopeC6 31, EnvelopeC65 32, EnvelopeB4 33 , | |
| 2241 | EnvelopeB5 34, EnvelopeB6 35, EnvelopeItaly 36 , | |
| 2242 | EnvelopeMonarch 37, EnvelopePersonal 38, FanfoldUS 39 , | |
| 2243 | FanfoldStdGerman 40, FanfoldLegalGerman 41, User 256 | |
| 2244 | ||
| 2245 | =item PageStart | |
| 2246 | ||
| 2247 | Start page number. | |
| 2248 | ||
| 2249 | =item UsePage | |
| 2250 | ||
| 2251 | Use own start page number (or not). | |
| 2252 | ||
| 2253 | =item LeftMergin, RightMergin, TopMergin, BottomMergin, HeaderMergin, FooterMergin | |
| 2254 | ||
| 2255 | Mergins for left, right, top, bottom, header and footer. | |
| 2256 | ||
| 2257 | =item HCenter | |
| 2258 | ||
| 2259 | Print in horizontal center (or not) | |
| 2260 | ||
| 2261 | =item VCenter | |
| 2262 | ||
| 2263 | Print in vertical center (or not) | |
| 2264 | ||
| 2265 | =item Header | |
| 2266 | ||
| 2267 | Content of print header. | |
| 2268 | Please refer Excel Help. | |
| 2269 | ||
| 2270 | =item Footer | |
| 2271 | ||
| 2272 | Content of print footer. | |
| 2273 | Please refer Excel Help. | |
| 2274 | ||
| 2275 | =item PrintGrid | |
| 2276 | ||
| 2277 | Print with Gridlines (or not) | |
| 2278 | ||
| 2279 | =item PrintHeaders | |
| 2280 | ||
| 2281 | Print with headings (or not) | |
| 2282 | ||
| 2283 | =item NoColor | |
| 2284 | ||
| 2285 | Print in black-white (or not). | |
| 2286 | ||
| 2287 | =item Draft | |
| 2288 | ||
| 2289 | Print in draft mode (or not). | |
| 2290 | ||
| 2291 | =item Notes | |
| 2292 | ||
| 2293 | Print with notes (or not). | |
| 2294 | ||
| 2295 | =item LeftToRight | |
| 2296 | ||
| 2297 | Print left to right(0) or top to down(1). | |
| 2298 | ||
| 2299 | =item HPageBreak | |
| 2300 | ||
| 2301 | Array ref of horizontal page breaks. | |
| 2302 | ||
| 2303 | =item VPageBreak | |
| 2304 | ||
| 2305 | Array ref of vertical page breaks. | |
| 2306 | ||
| 2307 | =item MergedArea | |
| 2308 | ||
| 2309 | Array ref of merged areas. | |
| 2310 | Each merged area is : [ I<StartRow>, I<StartColumn>, I<EndRow>, I<EndColumn>] | |
| 2311 | ||
| 2312 | =back | |
| 2313 | ||
| 2314 | =head2 Cell | |
| 2315 | ||
| 2316 | I<Spreadsheet::ParseExcel::Cell> | |
| 2317 | ||
| 2318 | Cell class has these properties: | |
| 2319 | ||
| 2320 | =over 4 | |
| 2321 | ||
| 2322 | =item Value | |
| 2323 | ||
| 2324 | I<Method> | |
| 2325 | Formatted value of that cell | |
| 2326 | ||
| 2327 | =item Val | |
| 2328 | ||
| 2329 | Original Value of that cell | |
| 2330 | ||
| 2331 | =item Type | |
| 2332 | ||
| 2333 | Kind of that cell ('Text', 'Numeric', 'Date') | |
| 2334 | ||
| 2335 | =item Code | |
| 2336 | ||
| 2337 | Character code of that cell (undef, 'ucs2', '_native_') | |
| 2338 | undef tells that cell seems to be ascii. | |
| 2339 | '_native_' tells that cell seems to be 'sjis' or something like that. | |
| 2340 | ||
| 2341 | =item Format | |
| 2342 | ||
| 2343 | L<"Format"> for that cell. | |
| 2344 | ||
| 2345 | =item Merged | |
| 2346 | ||
| 2347 | That cells is merged (or not). | |
| 2348 | ||
| 2349 | =item Rich | |
| 2350 | ||
| 2351 | Array ref of font informations about each characters. | |
| 2352 | ||
| 2353 | Each entry has : [ I<Start Position>, I<Font Object>] | |
| 2354 | ||
| 2355 | For more information please refer sample/dmpExR.pl | |
| 2356 | ||
| 2357 | =back | |
| 2358 | ||
| 2359 | =head2 Format | |
| 2360 | ||
| 2361 | I<Spreadsheet::ParseExcel::Format> | |
| 2362 | ||
| 2363 | Format class has these properties: | |
| 2364 | ||
| 2365 | =over 4 | |
| 2366 | ||
| 2367 | =item Font | |
| 2368 | ||
| 2369 | L<"Font"> object for that Format. | |
| 2370 | ||
| 2371 | =item AlignH | |
| 2372 | ||
| 2373 | Horizontal Alignment. | |
| 2374 | ||
| 2375 | 0: (standard), 1: left, 2: center, 3: right, | |
| 2376 | 4: fill , 5: justify, 7:equal_space | |
| 2377 | ||
| 2378 | B<Notice:> 6 may be I<merge> but it seems not to work. | |
| 2379 | ||
| 2380 | =item AlignV | |
| 2381 | ||
| 2382 | Vertical Alignment. | |
| 2383 | ||
| 2384 | 0: top, 1: vcenter, 2: bottom, 3: vjustify, 4: vequal_space | |
| 2385 | ||
| 2386 | =item Indent | |
| 2387 | ||
| 2388 | Number of indent | |
| 2389 | ||
| 2390 | =item Wrap | |
| 2391 | ||
| 2392 | Wrap (or not). | |
| 2393 | ||
| 2394 | =item Shrink | |
| 2395 | ||
| 2396 | Display in shrinking (or not) | |
| 2397 | ||
| 2398 | =item Rotate | |
| 2399 | ||
| 2400 | In Excel97, 2000 : degrees of string rotation. | |
| 2401 | In Excel95 or earlier : 0: No rotation, 1: Top down, 2: 90 degrees anti-clockwise, | |
| 2402 | 3: 90 clockwise | |
| 2403 | ||
| 2404 | =item JustLast | |
| 2405 | ||
| 2406 | JustLast (or not). | |
| 2407 | I<I have never seen this attribute.> | |
| 2408 | ||
| 2409 | =item ReadDir | |
| 2410 | ||
| 2411 | Direction for read. | |
| 2412 | ||
| 2413 | =item BdrStyle | |
| 2414 | ||
| 2415 | Array ref of boder styles : [I<Left>, I<Right>, I<Top>, I<Bottom>] | |
| 2416 | ||
| 2417 | =item BdrColor | |
| 2418 | ||
| 2419 | Array ref of boder color indexes : [I<Left>, I<Right>, I<Top>, I<Bottom>] | |
| 2420 | ||
| 2421 | =item BdrDiag | |
| 2422 | ||
| 2423 | Array ref of diag boder kind, style and color index : [I<Kind>, I<Style>, I<Color>] | |
| 2424 | Kind : 0: None, 1: Right-Down, 2:Right-Up, 3:Both | |
| 2425 | ||
| 2426 | =item Fill | |
| 2427 | ||
| 2428 | Array ref of fill pattern and color indexes : [I<Pattern>, I<Front Color>, I<Back Color>] | |
| 2429 | ||
| 2430 | =item Lock | |
| 2431 | ||
| 2432 | Locked (or not). | |
| 2433 | ||
| 2434 | =item Hidden | |
| 2435 | ||
| 2436 | Hiddedn (or not). | |
| 2437 | ||
| 2438 | =item Style | |
| 2439 | ||
| 2440 | Style format (or Cell format) | |
| 2441 | ||
| 2442 | =back | |
| 2443 | ||
| 2444 | =head2 Font | |
| 2445 | ||
| 2446 | I<Spreadsheet::ParseExcel::Font> | |
| 2447 | ||
| 2448 | Format class has these properties: | |
| 2449 | ||
| 2450 | =over 4 | |
| 2451 | ||
| 2452 | =item Name | |
| 2453 | ||
| 2454 | Name of that font. | |
| 2455 | ||
| 2456 | =item Bold | |
| 2457 | ||
| 2458 | Bold (or not). | |
| 2459 | ||
| 2460 | =item Italic | |
| 2461 | ||
| 2462 | Italic (or not). | |
| 2463 | ||
| 2464 | =item Height | |
| 2465 | ||
| 2466 | Size (height) of that font. | |
| 2467 | ||
| 2468 | =item Underline | |
| 2469 | ||
| 2470 | Underline (or not). | |
| 2471 | ||
| 2472 | =item UnderlineStyle | |
| 2473 | ||
| 2474 | 0: None, 1: Single, 2: Double, 0x21: Single(Account), 0x22: Double(Account) | |
| 2475 | ||
| 2476 | =item Color | |
| 2477 | ||
| 2478 | Color index for that font. | |
| 2479 | ||
| 2480 | =item Strikeout | |
| 2481 | ||
| 2482 | Strikeout (or not). | |
| 2483 | ||
| 2484 | =item Super | |
| 2485 | ||
| 2486 | 0: None, 1: Upper, 2: Lower | |
| 2487 | ||
| 2488 | =back | |
| 2489 | ||
| 2490 | =head1 Formatter class | |
| 2491 | ||
| 2492 | I<Spreadsheet::ParseExcel::Fmt*> | |
| 2493 | ||
| 2494 | Formatter class will convert cell data. | |
| 2495 | ||
| 2496 | Spreadsheet::ParseExcel includes 2 formatter classes: FmtDefault and FmtJapanese. | |
| 2497 | You can create your own FmtClass as you like. | |
| 2498 | ||
| 2499 | Formatter class(Spreadsheet::ParseExcel::Fmt*) should provide these functions: | |
| 2500 | ||
| 2501 | =over 4 | |
| 2502 | ||
| 2503 | =item ChkType($oSelf, $iNumeric, $iFmtIdx) | |
| 2504 | ||
| 2505 | tells type of the cell that has specified value. | |
| 2506 | ||
| 2507 | =over 8 | |
| 2508 | ||
| 2509 | =item $oSelf | |
| 2510 | ||
| 2511 | Formatter itself | |
| 2512 | ||
| 2513 | =item $iNumeric | |
| 2514 | ||
| 2515 | If on, the value seems to be number | |
| 2516 | ||
| 2517 | =item $iFmtIdx | |
| 2518 | ||
| 2519 | Format index number of that cell | |
| 2520 | ||
| 2521 | =back | |
| 2522 | ||
| 2523 | =item TextFmt($oSelf, $sText, $sCode) | |
| 2524 | ||
| 2525 | converts original text into applicatable for Value. | |
| 2526 | ||
| 2527 | =over 8 | |
| 2528 | ||
| 2529 | =item $oSelf | |
| 2530 | ||
| 2531 | Formatter itself | |
| 2532 | ||
| 2533 | =item $sText | |
| 2534 | ||
| 2535 | Original text | |
| 2536 | ||
| 2537 | =item $sCode | |
| 2538 | ||
| 2539 | Character code of Original text | |
| 2540 | ||
| 2541 | =back | |
| 2542 | ||
| 2543 | =item ValFmt($oSelf, $oCell, $oBook) | |
| 2544 | ||
| 2545 | converts original value into applicatable for Value. | |
| 2546 | ||
| 2547 | =over 8 | |
| 2548 | ||
| 2549 | =item $oSelf | |
| 2550 | ||
| 2551 | Formatter itself | |
| 2552 | ||
| 2553 | =item $oCell | |
| 2554 | ||
| 2555 | Cell object | |
| 2556 | ||
| 2557 | =item $oBook | |
| 2558 | ||
| 2559 | Workbook object | |
| 2560 | ||
| 2561 | =back | |
| 2562 | ||
| 2563 | =item FmtString($oSelf, $oCell, $oBook) | |
| 2564 | ||
| 2565 | get format string for the I<$oCell>. | |
| 2566 | ||
| 2567 | =over 8 | |
| 2568 | ||
| 2569 | =item $oSelf | |
| 2570 | ||
| 2571 | Formatter itself | |
| 2572 | ||
| 2573 | =item $oCell | |
| 2574 | ||
| 2575 | Cell object | |
| 2576 | ||
| 2577 | =item $oBook | |
| 2578 | ||
| 2579 | WorkBook object contains that cell | |
| 2580 | ||
| 2581 | =back | |
| 2582 | ||
| 2583 | =back | |
| 2584 | ||
| 2585 | =head1 KNOWN PROBLEM | |
| 2586 | ||
| 2587 | This module can not get the values of fomulas in | |
| 2588 | Excel files made with Spreadsheet::WriteExcel. | |
| 2589 | Normaly (ie. By Excel application), formula has the result with it. | |
| 2590 | But Spreadsheet::WriteExcel writes formula with no result. | |
| 2591 | If you set your Excel application "Auto Calculation" off. | |
| 2592 | (maybe [Tool]-[Option]-[Calculation] or something) | |
| 2593 | You will see the same result. | |
| 2594 | ||
| 2595 | =head1 AUTHOR | |
| 2596 | ||
| 2597 | Kawai Takanori (Hippo2000) kwitknr@cpan.org | |
| 2598 | ||
| 2599 | http://member.nifty.ne.jp/hippo2000/ (Japanese) | |
| 2600 | http://member.nifty.ne.jp/hippo2000/index_e.htm (English) | |
| 2601 | ||
| 2602 | =head1 SEE ALSO | |
| 2603 | ||
| 2604 | XLHTML, OLE::Storage, Spreadsheet::WriteExcel, OLE::Storage_Lite | |
| 2605 | ||
| 2606 | This module is based on herbert within OLE::Storage and XLHTML. | |
| 2607 | ||
| 2608 | =head1 TODO | |
| 2609 | ||
| 2610 | - Spreadsheet::ParseExcel : | |
| 2611 | Password protected data, Formulas support, HyperLink support, | |
| 2612 | Named Range support | |
| 2613 | ||
| 2614 | - Spreadsheet::ParseExcel::SaveParser : | |
| 2615 | Catch up Spreadsheet::WriteExce feature, Create new Excel fle | |
| 2616 | ||
| 2617 | =head1 COPYRIGHT | |
| 2618 | ||
| 2619 | Copyright (c) 2000-2002 Kawai Takanori | |
| 2620 | All rights reserved. | |
| 2621 | ||
| 2622 | You may distribute under the terms of either the GNU General Public | |
| 2623 | License or the Artistic License, as specified in the Perl README file. | |
| 2624 | ||
| 2625 | =head1 ACKNOWLEDGEMENTS | |
| 2626 | ||
| 2627 | First of all, I would like to acknowledge valuable program and modules : | |
| 2628 | XHTML, OLE::Storage and Spreadsheet::WriteExcel. | |
| 2629 | ||
| 2630 | In no particular order: Yamaji Haruna, Simamoto Takesi, Noguchi Harumi, | |
| 2631 | Ikezawa Kazuhiro, Suwazono Shugo, Hirofumi Morisada, Michael Edwards, Kim Namusk | |
| 2632 | and many many people + Kawai Mikako. | |
| 2633 | ||
| 2634 | =cut |
| 0 | #!/bin/env perl | |
| 1 | ||
| 2 | BEGIN { | |
| 3 | use File::Basename; | |
| 4 | unshift(@INC, dirname $0); | |
| 5 | } | |
| 6 | ||
| 7 | use strict; | |
| 8 | use Spreadsheet::ParseExcel; | |
| 9 | ||
| 10 | # declare some varibles local | |
| 11 | my($row, $col, $sheet, $cell, $usage, $basename, $sheetnumber, $filename); | |
| 12 | ||
| 13 | ## | |
| 14 | ## Usage information | |
| 15 | ## | |
| 16 | $usage = <<EOF; | |
| 17 | ||
| 18 | xls2csv.pl <excel file> [<output file>] [<worksheet number>] | |
| 19 | ||
| 20 | Translate the Microsoft Excel spreadsheet file contained in | |
| 21 | <excel file> into comma separated value format (CSV) and store | |
| 22 | in <output file>. | |
| 23 | ||
| 24 | If <output file> is not specified, the output file will have the | |
| 25 | same name as the input file with '.xls' or '.XLS' (if any) | |
| 26 | removed and '.csv' appended. | |
| 27 | ||
| 28 | If no worksheet number is given, each worksheet will be written to | |
| 29 | a separate file with the name '<output file>_<worksheet name>.csv'. | |
| 30 | ||
| 31 | EOF | |
| 32 | ||
| 33 | ## | |
| 34 | ## parse arguments | |
| 35 | ## | |
| 36 | ||
| 37 | if(!defined($ARGV[0])) | |
| 38 | { | |
| 39 | print $usage; | |
| 40 | exit 1; | |
| 41 | } | |
| 42 | ||
| 43 | $basename = $ARGV[1]; | |
| 44 | $basename =~ s/.csv//; | |
| 45 | if ($basename eq "") | |
| 46 | { | |
| 47 | my @path; | |
| 48 | @path = split(/[\/\\]/, $ARGV[0]); # split on file separator | |
| 49 | $basename = $path[$#path]; | |
| 50 | $basename =~ s/.xls//i; | |
| 51 | } | |
| 52 | ||
| 53 | if(defined($ARGV[2]) ) | |
| 54 | { | |
| 55 | $sheetnumber = $ARGV[2]; | |
| 56 | die "Sheetnumber must be an integer larger than 0." if $sheetnumber < 1; | |
| 57 | } | |
| 58 | ||
| 59 | ## | |
| 60 | ## open spreadsheet | |
| 61 | ## | |
| 62 | ||
| 63 | my $oExcel = new Spreadsheet::ParseExcel; | |
| 64 | ||
| 65 | print "Loading $ARGV[0] ...\n"; | |
| 66 | ||
| 67 | open(FH, "<$ARGV[0]") or die "Unable to open file '$ARGV[0]'.\n"; | |
| 68 | close(FH); | |
| 69 | ||
| 70 | my $oBook = $oExcel->Parse($ARGV[0]); | |
| 71 | ||
| 72 | print "\n"; | |
| 73 | print "Orignal Filename :", $oBook->{File} , "\n"; | |
| 74 | print "Number of Sheets :", $oBook->{SheetCount} , "\n"; | |
| 75 | print "Author :", $oBook->{Author} , "\n"; | |
| 76 | print "\n"; | |
| 77 | ||
| 78 | my @sheetlist = (@{$oBook->{Worksheet}}); | |
| 79 | if (defined($sheetnumber)) | |
| 80 | { | |
| 81 | @sheetlist=($sheetlist[$sheetnumber-1]); | |
| 82 | } | |
| 83 | ||
| 84 | ## | |
| 85 | ## iterate across each worksheet, writing out a separat csv file | |
| 86 | ## | |
| 87 | ||
| 88 | my $i=0; | |
| 89 | foreach my $sheet (@sheetlist) | |
| 90 | { | |
| 91 | $i++; | |
| 92 | ||
| 93 | my $sheetname = $sheet->{Name}; | |
| 94 | if(defined($sheetnumber)) | |
| 95 | { | |
| 96 | $filename = "${basename}.csv"; | |
| 97 | } | |
| 98 | else | |
| 99 | { | |
| 100 | $filename = "${basename}_${sheetname}.csv"; | |
| 101 | } | |
| 102 | ||
| 103 | print "Writing Sheet number $i ('$sheetname') to file '$filename'\n"; | |
| 104 | ||
| 105 | open(OutFile,">$filename"); | |
| 106 | ||
| 107 | my $cumulativeBlankLines=0; | |
| 108 | ||
| 109 | my $minrow = $sheet->{MinRow}; | |
| 110 | my $maxrow = $sheet->{MaxRow}; | |
| 111 | my $mincol = $sheet->{MinCol}; | |
| 112 | my $maxcol = $sheet->{MaxCol}; | |
| 113 | ||
| 114 | print "Minrow=$minrow Maxrow=$maxrow Mincol=$mincol Maxcol=$maxcol\n"; | |
| 115 | ||
| 116 | for(my $row = $minrow; $row <= $maxrow; $row++) | |
| 117 | { | |
| 118 | my $outputLine = ""; | |
| 119 | ||
| 120 | for(my $col = $mincol; $col <= $maxcol; $col++) | |
| 121 | { | |
| 122 | my $cell = $sheet->{Cells}[$row][$col]; | |
| 123 | if( defined($cell) ) | |
| 124 | { | |
| 125 | $_=$cell->Value; #{Val}; | |
| 126 | ||
| 127 | # convert '#NUM!' strings to missing (empty) values | |
| 128 | s/#NUM!//; | |
| 129 | ||
| 130 | # escape double-quote characters in the data since | |
| 131 | # they are used as field delimiters | |
| 132 | s/\"/\\\"/g; | |
| 133 | } | |
| 134 | else | |
| 135 | { | |
| 136 | $_ = ''; | |
| 137 | } | |
| 138 | ||
| 139 | $outputLine .= "\"" . $_ . "\"" if(length($_)>0); | |
| 140 | ||
| 141 | # separate cells with commas | |
| 142 | $outputLine .= "," if( $col != $maxcol) ; | |
| 143 | ||
| 144 | } | |
| 145 | ||
| 146 | #$outputLine =~ s/[, ]+$//g; ## strip off trailing blanks and commas | |
| 147 | ||
| 148 | # skip blank/empty lines | |
| 149 | if( $outputLine =~ /^[, ]*$/ ) | |
| 150 | { | |
| 151 | $cumulativeBlankLines++ | |
| 152 | } | |
| 153 | else | |
| 154 | { | |
| 155 | print OutFile "$outputLine \n" | |
| 156 | } | |
| 157 | } | |
| 158 | ||
| 159 | close OutFile; | |
| 160 | ||
| 161 | print " (Ignored $cumulativeBlankLines blank lines.)\n" | |
| 162 | if ($cumulativeBlankLines); | |
| 163 | print "\n"; | |
| 164 | } | |
| 165 |
Binary diff not shown
| 0 | \name{Args} | |
| 1 | \alias{Args} | |
| 2 | \title{ | |
| 3 | Formatted Argument List of a Function | |
| 4 | } | |
| 5 | \description{ | |
| 6 | Display function argument names and corresponding default values, | |
| 7 | formatted in two columns for easy reading. | |
| 8 | } | |
| 9 | \usage{ | |
| 10 | Args(name, sort.args = FALSE) | |
| 11 | } | |
| 12 | \arguments{ | |
| 13 | \item{name}{a function or function name.} | |
| 14 | \item{sort.args}{whether arguments should be sorted.} | |
| 15 | } | |
| 16 | \value{ | |
| 17 | A data frame with named rows and a single column called \code{value}, | |
| 18 | containing the default value of each argument. | |
| 19 | } | |
| 20 | \author{Arni Magnusson \email{arnima@u.washington.edu}} | |
| 21 | \seealso{ | |
| 22 | \code{\link{args}}, | |
| 23 | \code{\link{formals}}, | |
| 24 | \code{\link{help}}. | |
| 25 | } | |
| 26 | \examples{ | |
| 27 | Args(glm) | |
| 28 | Args(scan) | |
| 29 | Args(legend) | |
| 30 | } | |
| 31 | % Programming | |
| 32 | \keyword{programming} | |
| 33 | \keyword{utilities} | |
| 34 | \keyword{documentation} |
| 0 | \name{ConvertMedUnits} | |
| 1 | \alias{ConvertMedUnits} | |
| 2 | \title{Convert medical measurements between International Standard (SI) | |
| 3 | and US 'Conventional' Units.} | |
| 4 | \description{ | |
| 5 | Convert Medical measurements between International Standard (SI) | |
| 6 | and US 'Conventional' Units. | |
| 7 | } | |
| 8 | \usage{ | |
| 9 | ConvertMedUnits(x, measurement, abbreviation, | |
| 10 | to = c("Conventional", "SI", "US"), | |
| 11 | exact = !missing(abbreviation)) | |
| 12 | } | |
| 13 | \arguments{ | |
| 14 | \item{x}{Vector of measurement values} | |
| 15 | \item{measurement}{Name of the measurement} | |
| 16 | \item{abbreviation}{Measurement abbreviation} | |
| 17 | \item{to}{Target units} | |
| 18 | \item{exact}{Logicial indicating whether matching should be exact} | |
| 19 | } | |
| 20 | \details{ | |
| 21 | ||
| 22 | Medical laboratories and practitioners in the United States use one | |
| 23 | set of units (the so-called 'Conventional' units) for reporting the | |
| 24 | results of clinical laboratory measurements, while the rest of the | |
| 25 | world uses the International Standard (SI) units. It often becomes | |
| 26 | necessary to translate between these units when participating in | |
| 27 | international collaborations. | |
| 28 | ||
| 29 | This function converts between SI and US 'Conventional' units. | |
| 30 | ||
| 31 | If \code{exact=FALSE}, \code{grep} will be used to do a | |
| 32 | case-insensitive sub-string search for matching measurment names. If | |
| 33 | more than one match is found, an error will be generated, along with a | |
| 34 | list of the matching entries. | |
| 35 | ||
| 36 | } | |
| 37 | \value{ | |
| 38 | Returns a vector of converted values. The attribute 'units' will | |
| 39 | contain the target units converted. | |
| 40 | } | |
| 41 | \seealso{ | |
| 42 | The data set \code{\link{MedUnits}} provides the conversion | |
| 43 | factors. | |
| 44 | } | |
| 45 | \references{ | |
| 46 | \url{http://www.globalrph.com/conv_si.htm} | |
| 47 | } | |
| 48 | \author{Gregory R. Warnes \email{Gregory.R.Warnes@Pfizer.com} } | |
| 49 | \examples{ | |
| 50 | data(MedUnits) | |
| 51 | ||
| 52 | # show available conversions | |
| 53 | MedUnits$Measurement | |
| 54 | ||
| 55 | # Convert SI Glucose measurement to 'Conventional' units | |
| 56 | GlucoseSI = c(5, 5.4, 5, 5.1, 5.6, 5.1, 4.9, 5.2, 5.5) # in SI Units | |
| 57 | GlucoseUS = ConvertMedUnits( GlucoseSI, "Glucose", to="US" ) | |
| 58 | cbind(GlucoseSI,GlucoseUS) | |
| 59 | ||
| 60 | \dontrun{ | |
| 61 | # See what happens when there is more than one match | |
| 62 | ConvertMedUnits( 27.5, "Creatin", to="US") | |
| 63 | } | |
| 64 | ||
| 65 | # To solve the problem do: | |
| 66 | ConvertMedUnits( 27.5, "Creatinine", to="US", exact=TRUE) | |
| 67 | } | |
| 68 | \keyword{manip} |
| 0 | \name{MedUnits} | |
| 1 | \alias{MedUnits} | |
| 2 | \docType{data} | |
| 3 | \title{ | |
| 4 | Table of conversions between Intertional | |
| 5 | Standard (SI) and US 'Conventional' Units for common medical | |
| 6 | measurements. | |
| 7 | } | |
| 8 | \description{ | |
| 9 | Table of conversions between Intertional | |
| 10 | Standard (SI) and US 'Conventional' Units for common medical | |
| 11 | measurements. | |
| 12 | } | |
| 13 | \usage{data(MedUnits)} | |
| 14 | \format{ | |
| 15 | A data frame with the following 5 variables. | |
| 16 | \describe{ | |
| 17 | \item{Abbreviation}{Common Abbreviation (mostly missing)} | |
| 18 | \item{Measurement}{Measurement Name} | |
| 19 | \item{SIUnit}{SI Unit} | |
| 20 | \item{Conversion}{Conversion factor} | |
| 21 | \item{ConvetionalUnit}{Conventional Unit} | |
| 22 | } | |
| 23 | } | |
| 24 | \details{ | |
| 25 | ||
| 26 | Medical laboratories and practitioners in the United States use one | |
| 27 | set of units (the so-called 'Conventional' units) for reporting the | |
| 28 | results of clinical laboratory measurements, while the rest of the | |
| 29 | world uses the International Standard (SI) units. It often becomes | |
| 30 | necessary to translate between these units when participating in | |
| 31 | international collaborations. | |
| 32 | ||
| 33 | This data set provides constants for converting between SI and | |
| 34 | US 'Conventional' units. | |
| 35 | ||
| 36 | To perform the conversion from SI units to US 'Conventional' units do: | |
| 37 | ||
| 38 | Measurement in \code{ConventionalUnit} = | |
| 39 | (Measurement in \code{SIUnit}) / \code{Conversion} | |
| 40 | ||
| 41 | To perform conversion from 'Conventional' to SI units do: | |
| 42 | ||
| 43 | Measurement in \code{SIUnit} = | |
| 44 | (Measurement in \code{ConventionalUnit}) * \code{Conversion} | |
| 45 | ||
| 46 | } | |
| 47 | \source{ | |
| 48 | \url{http://www.globalrph.com/conv_si.htm} | |
| 49 | } | |
| 50 | \seealso{ | |
| 51 | The function \code{\link{ConvertMedUnits}} automates the | |
| 52 | conversion task. | |
| 53 | } | |
| 54 | \examples{ | |
| 55 | ||
| 56 | data(MedUnits) | |
| 57 | ||
| 58 | # show available conversions | |
| 59 | MedUnits$Measurement | |
| 60 | ||
| 61 | # utility function | |
| 62 | matchUnits <- function(X) MedUnits[ grep(X, MedUnits$Measurement),] | |
| 63 | ||
| 64 | # Convert SI Glucose measurement to 'Conventional' units | |
| 65 | GlucoseSI = c(5, 5.4, 5, 5.1, 5.6, 5.1, 4.9, 5.2, 5.5) # in SI Units | |
| 66 | GlucoseUS = GlucoseSI / matchUnits("Glucose")$Conversion | |
| 67 | cbind(GlucoseSI,GlucoseUS) | |
| 68 | ||
| 69 | # also consider using ConvertMedUnits() | |
| 70 | ConvertMedUnits( GlucoseSI, "Glucose", to="US" ) | |
| 71 | } | |
| 72 | \keyword{datasets} |
| 0 | % $Id: aggregate.table.Rd,v 1.6 2005/06/09 14:20:25 nj7w Exp $ | |
| 1 | % | |
| 2 | % $Log: aggregate.table.Rd,v $ | |
| 3 | % Revision 1.6 2005/06/09 14:20:25 nj7w | |
| 4 | % Updating the version number, and various help files to synchronize splitting of gregmisc bundle in 4 individual components. | |
| 5 | % | |
| 6 | % Revision 1.1.1.1 2005/05/25 22:07:33 nj7w | |
| 7 | % Initial entry for individual package gdata | |
| 8 | % | |
| 9 | % Revision 1.5 2003/11/17 22:09:00 warnes | |
| 10 | % Fix syntax error. | |
| 11 | % | |
| 12 | % Revision 1.4 2003/06/07 17:58:37 warnes | |
| 13 | % | |
| 14 | % - Fixed error in examples. Had sqrt(var(x)/(n-1)) for the standard | |
| 15 | % error of the mean instead of sqrt(var(x)/n). | |
| 16 | % | |
| 17 | % Revision 1.3 2002/09/23 13:59:30 warnes | |
| 18 | % - Modified all files to include CVS Id and Log tags. | |
| 19 | % | |
| 20 | % | |
| 21 | ||
| 22 | \name{aggregate.table} | |
| 23 | \alias{aggregate.table} | |
| 24 | \title{Create 2-Way Table of Summary Statistics} | |
| 25 | \description{ | |
| 26 | Splits the data into subsets based on two factors, computes a summary | |
| 27 | statistic on each subset, and arranges the results in a 2-way table. | |
| 28 | } | |
| 29 | \usage{ | |
| 30 | aggregate.table(x, by1, by2, FUN=mean, ...) | |
| 31 | } | |
| 32 | %- maybe also `usage' for other objects documented here. | |
| 33 | \arguments{ | |
| 34 | \item{x}{ data to be summarized } | |
| 35 | \item{by1}{ first grouping factor. } | |
| 36 | \item{by2}{ second grouping factor. } | |
| 37 | \item{FUN}{ a scalar function to compute the summary statistics which can | |
| 38 | be applied to all data subsets. Defaults to \code{mean}.} | |
| 39 | \item{\dots}{ Optional arguments for \code{FUN}. } | |
| 40 | } | |
| 41 | %\details{ | |
| 42 | % ~~ If necessary, more details than the __description__ above ~~ | |
| 43 | %} | |
| 44 | \value{ | |
| 45 | Returns a matrix with one element for each combination of \code{by1} | |
| 46 | and \code{by2}. | |
| 47 | } | |
| 48 | \author{ Gregory R. Warnes \email{gregory\_r\_warnes\@groton.pfizer.com}} | |
| 49 | ||
| 50 | \seealso{ \code{\link{aggregate}}, \code{\link{tapply}}, | |
| 51 | \code{\link{interleave}} } | |
| 52 | ||
| 53 | \examples{ | |
| 54 | # Useful example: | |
| 55 | # | |
| 56 | # Create a 2-way table of means, standard errors, and # obs | |
| 57 | ||
| 58 | g1 <- sample(letters[1:5], 1000, replace=TRUE) | |
| 59 | g2 <- sample(LETTERS[1:3], 1000, replace=TRUE ) | |
| 60 | dat <- rnorm(1000) | |
| 61 | ||
| 62 | stderr <- function(x) sqrt( var(x,na.rm=TRUE) / nobs(x) ) | |
| 63 | ||
| 64 | means <- aggregate.table( dat, g1, g2, mean ) | |
| 65 | stderrs <- aggregate.table( dat, g1, g2, stderr ) | |
| 66 | ns <- aggregate.table( dat, g1, g2, nobs ) | |
| 67 | blanks <- matrix( " ", nrow=5, ncol=3) | |
| 68 | ||
| 69 | tab <- interleave( "Mean"=round(means,2), | |
| 70 | "Std Err"=round(stderrs,2), | |
| 71 | "N"=ns, " " = blanks, sep=" " ) | |
| 72 | ||
| 73 | print(tab, quote=FALSE) | |
| 74 | } | |
| 75 | \keyword{iteration} | |
| 76 | \keyword{category} | |
| 77 |
| 0 | % $Id: combine.Rd,v 1.3 2005/06/09 14:20:25 nj7w Exp $ | |
| 1 | % | |
| 2 | % $Log: combine.Rd,v $ | |
| 3 | % Revision 1.3 2005/06/09 14:20:25 nj7w | |
| 4 | % Updating the version number, and various help files to synchronize splitting of gregmisc bundle in 4 individual components. | |
| 5 | % | |
| 6 | % Revision 1.1.1.1 2005/05/25 22:07:33 nj7w | |
| 7 | % Initial entry for individual package gdata | |
| 8 | % | |
| 9 | % Revision 1.2 2002/09/23 13:59:30 warnes | |
| 10 | % - Modified all files to include CVS Id and Log tags. | |
| 11 | % | |
| 12 | % | |
| 13 | ||
| 14 | \name{combine} | |
| 15 | \alias{combine} | |
| 16 | \title{ Combine R Objects With a Column Labeling the Source} | |
| 17 | \description{ | |
| 18 | Take a sequence of vector, matrix or data frames and | |
| 19 | combine into rows of a common data frame with an additional column | |
| 20 | \code{source} indicating the source object. | |
| 21 | } | |
| 22 | \usage{ | |
| 23 | combine(..., names=NULL) | |
| 24 | } | |
| 25 | \arguments{ | |
| 26 | \item{\dots}{vectors or matrices to combine.} | |
| 27 | \item{names}{character vector of names to use when creating source column.} | |
| 28 | } | |
| 29 | \details{ | |
| 30 | If there are several matrix arguments, they must all have the same | |
| 31 | number of columns. The number of columns in the result will be one | |
| 32 | larger than the number of columns in the component matrixes. If all | |
| 33 | of the arguments are vectors, these are treated as single column | |
| 34 | matrixes. In this case, the column containing the combineinated | |
| 35 | vector data is labeled \code{data}. | |
| 36 | ||
| 37 | When the arguments consist of a mix of matrices and vectors the | |
| 38 | number of columns of the result is determined by the number | |
| 39 | of columns of the matrix arguments. Vectors are considered row | |
| 40 | vectors and have their values recycled or subsetted (if necessary) | |
| 41 | to achieve this length. | |
| 42 | ||
| 43 | The \code{source} column is created as a factor with levels | |
| 44 | corresponding to the name of the object from which the each row was | |
| 45 | obtained. When the \code{names} argument is ommitted, the name of | |
| 46 | each object is obtained from the specified argument name in the | |
| 47 | call (if present) or from the name of the object. See below for | |
| 48 | examples. | |
| 49 | } | |
| 50 | % \value{ | |
| 51 | % ~Describe the value returned | |
| 52 | % If it is a LIST, use | |
| 53 | % \item{comp1 }{Description of `comp1'} | |
| 54 | % \item{comp2 }{Description of `comp2'} | |
| 55 | % ... | |
| 56 | % } | |
| 57 | %\references{ ~put references to the literature/web site here ~ } | |
| 58 | \author{Gregory R. Warnes \email{Gregory\_R\_Warnes@groton.pfizer.com}} | |
| 59 | %\note{ ~~further notes~~ } | |
| 60 | \seealso{ \code{\link{rbind}}, \code{\link{merge}}} | |
| 61 | ||
| 62 | \examples{ | |
| 63 | ||
| 64 | a <- matrix(rnorm(12),ncol=4,nrow=3) | |
| 65 | b <- 1:4 | |
| 66 | combine(a,b) | |
| 67 | ||
| 68 | combine(x=a,b) | |
| 69 | combine(x=a,y=b) | |
| 70 | combine(a,b,names=c("one","two")) | |
| 71 | ||
| 72 | c <- 1:6 | |
| 73 | combine(b,c) | |
| 74 | } | |
| 75 | ||
| 76 | \keyword{array} | |
| 77 | \keyword{manip} | |
| 78 |
| 0 | % $Id: drop.levels.Rd,v 1.2 2005/06/09 14:20:25 nj7w Exp $ | |
| 1 | % | |
| 2 | \name{drop.levels} | |
| 3 | \alias{drop.levels} | |
| 4 | \title{Drop unused factor levels} | |
| 5 | \description{Drop unused factor levels for every factor variable in a data frame. | |
| 6 | } | |
| 7 | \usage{ | |
| 8 | drop.levels(x, reorder = TRUE, ...) | |
| 9 | } | |
| 10 | \arguments{ | |
| 11 | \item{x}{a data frame} | |
| 12 | \item{reorder}{should factor levels be reordered using | |
| 13 | \code{\link{reorder.factor}}?} | |
| 14 | \item{...}{additional arguments to \code{reorder.factor}} | |
| 15 | } | |
| 16 | \value{a data frame | |
| 17 | } | |
| 18 | \author{Jim Rogers \email{james\_a\_rogers@groton.pfizer.com}} | |
| 19 | \keyword{manip} |
| 0 | \name{elem} | |
| 1 | \alias{elem} | |
| 2 | \title{ | |
| 3 | Display Information about Elements in a Given Object | |
| 4 | } | |
| 5 | \description{ | |
| 6 | \emph{This function is depreciated. Please use \code{\link{ll}} | |
| 7 | instead.} | |
| 8 | ||
| 9 | Display name, class, size, and dimensions of each element in a given | |
| 10 | object. | |
| 11 | } | |
| 12 | \usage{ | |
| 13 | elem(object=1, unit=c("KB","MB","bytes"), digits=0, | |
| 14 | dimensions=FALSE) | |
| 15 | } | |
| 16 | \arguments{ | |
| 17 | \item{object}{object containing named elements, perhaps a model or | |
| 18 | data frame.} | |
| 19 | \item{unit}{required unit for displaying element size: "KB", "MB", | |
| 20 | "bytes", or first letter.} | |
| 21 | \item{digits}{number of decimals to display when rounding element | |
| 22 | size.} | |
| 23 | \item{dimensions}{whether element dimensions should be returned.} | |
| 24 | } | |
| 25 | \details{ | |
| 26 | A verbose alternative to \code{names()}. | |
| 27 | } | |
| 28 | \value{ | |
| 29 | A data frame with named rows and the following columns: | |
| 30 | \item{Class}{element class.} | |
| 31 | \item{KB}{element size \emph{(see notes)}.} | |
| 32 | \item{Dim}{element dimensions \emph{(optional)}.} | |
| 33 | } | |
| 34 | \note{ | |
| 35 | The name of the element size column is the same as the unit used. | |
| 36 | ||
| 37 | Elements of class \code{classRepresentation}, | |
| 38 | \code{ClassUnionRepresentation}, and \code{grob} do not have a defined | |
| 39 | size, so 0 bytes are assumed for those. | |
| 40 | } | |
| 41 | \author{Arni Magnusson \email{arnima@u.washington.edu}} | |
| 42 | \seealso{ | |
| 43 | ||
| 44 | \code{\link[base]{names}}, \code{\link[utils]{str}}, and | |
| 45 | \code{\link[base]{summary}} display different information about object | |
| 46 | elements. | |
| 47 | ||
| 48 | \code{\link{ll}} and \code{\link{env}} are related to \code{elem}. | |
| 49 | } | |
| 50 | \examples{ | |
| 51 | \dontrun{ | |
| 52 | data(infert) | |
| 53 | elem(infert) | |
| 54 | model <- glm(case~spontaneous+induced, family=binomial, data=infert) | |
| 55 | elem(model, dim=TRUE) | |
| 56 | elem(model$family) | |
| 57 | } | |
| 58 | } | |
| 59 | % Basics | |
| 60 | \keyword{attribute} | |
| 61 | \keyword{classes} | |
| 62 | \keyword{list} | |
| 63 | % Programming | |
| 64 | \keyword{print} | |
| 65 | \keyword{utilities} |
| 0 | \name{env} | |
| 1 | \alias{env} | |
| 2 | \title{ | |
| 3 | Display Information about All Loaded Environments | |
| 4 | } | |
| 5 | \description{ | |
| 6 | Display name, number of objects, and size of all loaded environments. | |
| 7 | } | |
| 8 | \usage{ | |
| 9 | env(unit=c("KB","MB","bytes"), digits=0) | |
| 10 | } | |
| 11 | \arguments{ | |
| 12 | \item{unit}{required unit for displaying environment size: "bytes", | |
| 13 | "KB", "MB", or first letter.} | |
| 14 | \item{digits}{number of decimals to display when rounding environment | |
| 15 | size.} | |
| 16 | } | |
| 17 | \details{ | |
| 18 | A verbose alternative to \code{search()}. | |
| 19 | } | |
| 20 | \value{ | |
| 21 | A data frame with the following columns: | |
| 22 | \item{Environment}{environment name.} | |
| 23 | \item{Objects}{number of objects in environment.} | |
| 24 | \item{KB}{environment size \emph{(see notes)}.} | |
| 25 | } | |
| 26 | \note{ | |
| 27 | The name of the environment size column is the same as the unit used. | |
| 28 | } | |
| 29 | \author{Arni Magnusson \email{arnima@u.washington.edu}} | |
| 30 | \seealso{ | |
| 31 | \code{\link{search}} displays environment names. | |
| 32 | ||
| 33 | \code{\link{ll}} is related to \code{env}. | |
| 34 | } | |
| 35 | \examples{ | |
| 36 | \dontrun{ | |
| 37 | env() | |
| 38 | } | |
| 39 | } | |
| 40 | % Basics | |
| 41 | \keyword{data} | |
| 42 | % Programming | |
| 43 | \keyword{environment} | |
| 44 | \keyword{utilities} |
| 0 | % $Id% | |
| 1 | % | |
| 2 | \name{frameApply} | |
| 3 | \alias{frameApply} | |
| 4 | \title{Subset analysis on data frames} | |
| 5 | \description{Apply a function to row subsets of a data frame. | |
| 6 | } | |
| 7 | \usage{ | |
| 8 | frameApply(x, by = NULL, on = by[1], fun = function(xi) c(Count = | |
| 9 | nrow(xi)), subset = TRUE, simplify = TRUE, byvar.sep = "\\$\\@\\$", ...) | |
| 10 | } | |
| 11 | \arguments{ | |
| 12 | \item{x}{a data frame} | |
| 13 | \item{by}{names of columns in \code{x} specifying the variables to use | |
| 14 | to form the subgroups. | |
| 15 | None of the \code{by} variables should have | |
| 16 | the name "sep" (you will get an error if one of them does; a bit of | |
| 17 | laziness in the code). Unused levels of | |
| 18 | the \code{by} variables will be dropped. Use \code{by = NULL} (the | |
| 19 | default) to indicate that all of the data is to be treated as a | |
| 20 | single (trivial) subgroup.} | |
| 21 | \item{on}{names of columns in \code{x} specifying columns over which | |
| 22 | \code{fun} is to be applied. These can include columns specified in | |
| 23 | \code{by}, (as with the default) although that is not usually the case.} | |
| 24 | \item{fun}{a function that can operate on data frames that are row | |
| 25 | subsets of \code{x[on]}. If \code{simplify = TRUE}, | |
| 26 | the return value of the function should always be either a try-error | |
| 27 | (see \code{\link{try}}), or a vector of | |
| 28 | fixed length (i.e. same length for every subset), preferably with | |
| 29 | named elements.} | |
| 30 | \item{subset}{logical vector (can be specified in terms of variables | |
| 31 | in data). This row subset of \code{x} is taken before doing anything | |
| 32 | else.} | |
| 33 | \item{simplify}{logical. If TRUE (the default), return value will | |
| 34 | be a data frame including the \code{by} columns and a column for | |
| 35 | each element of the return vector of \code{fun}. If FALSE, the | |
| 36 | return value will be a list, sometimes necessary for less structured | |
| 37 | output (see description of return value below).} | |
| 38 | \item{byvar.sep}{character. This can be any character string not | |
| 39 | found anywhere in the values of the \code{by} variables. The | |
| 40 | \code{by} variables will be pasted together using this as the | |
| 41 | separator, and the result will be used as the index to form the | |
| 42 | subgroups. } | |
| 43 | \item{...}{additional arguments to \code{fun}.} | |
| 44 | } | |
| 45 | \value{a data frame if \code{simplify = TRUE} (the default), assuming | |
| 46 | there is sufficiently structured output from \code{fun}. If | |
| 47 | \code{simplify = FALSE} and \code{by} is not NULL, the return value will be a list with two | |
| 48 | elements. The first element, named "by", will be a data frame with the | |
| 49 | unique rows of \code{x[by]}, and the second element, named "result" | |
| 50 | will be a list where the ith | |
| 51 | component gives the result for the ith row of the "by" element. | |
| 52 | } | |
| 53 | \details{This function accomplishes something similar to | |
| 54 | \code{\link{by}}. The main difference is that \code{frameApply} is | |
| 55 | designed to return data frames and lists instead of objects of class | |
| 56 | 'by'. Also, \code{frameApply} works only on the unique combinations of | |
| 57 | the \code{by} that are actually present in the data, not on the entire | |
| 58 | cartesian product of the \code{by} variables. In some cases this | |
| 59 | results in great gains in efficiency, although \code{frameApply} is | |
| 60 | hardly an efficient function.} | |
| 61 | ||
| 62 | \examples{ | |
| 63 | library(gtools) | |
| 64 | data(ELISA) | |
| 65 | ||
| 66 | # Default is slightly unintuitive, but commonly useful: | |
| 67 | frameApply(ELISA, by = c("PlateDay", "Read")) | |
| 68 | ||
| 69 | # Wouldn't actually recommend this model! Just a demo: | |
| 70 | frameApply(ELISA, on = c("Signal", "Concentration"), by = c("PlateDay", "Read"), | |
| 71 | fun = function(dat) coef(lm(Signal ~ Concentration, data = | |
| 72 | dat))) | |
| 73 | ||
| 74 | frameApply(ELISA, on = "Signal", by = "Concentration", | |
| 75 | fun = function(dat, ...) { | |
| 76 | x <- dat[[1]] | |
| 77 | out <- c(Mean = mean(x, ...), | |
| 78 | SD = sd(x, ...), | |
| 79 | N = sum(!is.na(x))) | |
| 80 | }, | |
| 81 | na.rm = TRUE, | |
| 82 | subset = !is.na(Concentration)) | |
| 83 | } | |
| 84 | \author{Jim Rogers \email{james\_a\_rogers@groton.pfizer.com}} | |
| 85 | \keyword{manip} | |
| 86 |
| 0 | % $Id: interleave.Rd,v 1.5 2005/06/09 14:20:25 nj7w Exp $ | |
| 1 | % | |
| 2 | % $Log: interleave.Rd,v $ | |
| 3 | % Revision 1.5 2005/06/09 14:20:25 nj7w | |
| 4 | % Updating the version number, and various help files to synchronize splitting of gregmisc bundle in 4 individual components. | |
| 5 | % | |
| 6 | % Revision 1.1.1.1 2005/05/25 22:07:33 nj7w | |
| 7 | % Initial entry for individual package gdata | |
| 8 | % | |
| 9 | % Revision 1.4 2003/06/07 17:58:37 warnes | |
| 10 | % | |
| 11 | % - Fixed error in examples. Had sqrt(var(x)/(n-1)) for the standard | |
| 12 | % error of the mean instead of sqrt(var(x)/n). | |
| 13 | % | |
| 14 | % Revision 1.3 2002/09/23 13:59:30 warnes | |
| 15 | % - Modified all files to include CVS Id and Log tags. | |
| 16 | % | |
| 17 | % Revision 1.2 2002/04/09 00:51:32 warneg | |
| 18 | % | |
| 19 | % Checkin for version 0.5.3 | |
| 20 | % | |
| 21 | % Revision 1.1 2002/02/20 21:41:54 warneg | |
| 22 | % Initial checkin. | |
| 23 | % | |
| 24 | % | |
| 25 | ||
| 26 | ||
| 27 | \name{interleave} | |
| 28 | \alias{interleave} | |
| 29 | \title{ Interleave Rows of Data Frames or Matrices } | |
| 30 | \description{ | |
| 31 | Interleave rows of data frames or Matrices. | |
| 32 | } | |
| 33 | \usage{ | |
| 34 | interleave(..., append.source=TRUE, sep=": ") | |
| 35 | } | |
| 36 | \arguments{ | |
| 37 | \item{\dots}{ objects to be interleaved } | |
| 38 | \item{append.source}{Boolean Flag. When \code{TRUE} (the default) the | |
| 39 | argument name will be appended to the row names to show the source of | |
| 40 | each row. } | |
| 41 | \item{sep}{Separator between the original row name and the object name.} | |
| 42 | } | |
| 43 | \details{ | |
| 44 | This function creates a new matrix or data frame from its arguments. | |
| 45 | ||
| 46 | The new object will have all of the rows from the source objects | |
| 47 | interleaved. IE, it will contain row 1 of object 1, followed by row 1 | |
| 48 | of object 2, .. row 1 of object 'n', row 2 of object 1, row 2 of | |
| 49 | object 2, ... row 2 of object 'n' ... | |
| 50 | } | |
| 51 | \value{ | |
| 52 | Matrix containing the interleaved rows of the function arguments. | |
| 53 | } | |
| 54 | \author{ Gregory R. Warnes \email{gregory\_r\_warnes\@groton.pfizer.com} | |
| 55 | } | |
| 56 | \seealso{ \code{\link{cbind}}, \code{\link{rbind}}, \code{\link{combine}} } | |
| 57 | ||
| 58 | \examples{ | |
| 59 | ||
| 60 | # Simple example | |
| 61 | a <- matrix(1:10,ncol=2,byrow=TRUE) | |
| 62 | b <- matrix(letters[1:10],ncol=2,byrow=TRUE) | |
| 63 | c <- matrix(LETTERS[1:10],ncol=2,byrow=TRUE) | |
| 64 | interleave(a,b,c) | |
| 65 | ||
| 66 | # Useful example: | |
| 67 | # | |
| 68 | # Create a 2-way table of means, standard errors, and # obs | |
| 69 | ||
| 70 | g1 <- sample(letters[1:5], 1000, replace=TRUE) | |
| 71 | g2 <- sample(LETTERS[1:3], 1000, replace=TRUE ) | |
| 72 | dat <- rnorm(1000) | |
| 73 | ||
| 74 | stderr <- function(x) sqrt( var(x,na.rm=TRUE) / nobs(x) ) | |
| 75 | ||
| 76 | means <- aggregate.table( dat, g1, g2, mean ) | |
| 77 | stderrs <- aggregate.table( dat, g1, g2, stderr ) | |
| 78 | ns <- aggregate.table( dat, g1, g2, nobs ) | |
| 79 | blanks <- matrix( " ", nrow=5, ncol=3) | |
| 80 | ||
| 81 | tab <- interleave( "Mean"=round(means,2), | |
| 82 | "Std Err"=round(stderrs,2), | |
| 83 | "N"=ns, " " = blanks, sep=" " ) | |
| 84 | ||
| 85 | print(tab, quote=FALSE) | |
| 86 | ||
| 87 | } | |
| 88 | \keyword{category} | |
| 89 | \keyword{array} | |
| 90 |
| 0 | \name{is.what} | |
| 1 | \alias{is.what} | |
| 2 | \title{ | |
| 3 | Run Multiple is.* Tests on a Given Object | |
| 4 | } | |
| 5 | \description{ | |
| 6 | Run multiple \code{is.*} tests on a given object, such as | |
| 7 | \code{is.numeric()}, \code{is.list()}, ... | |
| 8 | } | |
| 9 | \usage{ | |
| 10 | is.what(object, verbose = FALSE) | |
| 11 | } | |
| 12 | \arguments{ | |
| 13 | \item{object}{any R object.} | |
| 14 | \item{verbose}{whether negative tests should be included in output.} | |
| 15 | } | |
| 16 | \value{ | |
| 17 | A character vector containing positive tests, or when \code{verbose} | |
| 18 | is \code{TRUE}, a data frame showing all test results. | |
| 19 | } | |
| 20 | \author{Arni Magnusson \email{arnima@u.washington.edu}, inspired by | |
| 21 | \code{demo(is.things)}.} | |
| 22 | \seealso{ | |
| 23 | \code{\link{is.na}} and \code{\link{is.numeric}} are commonly used | |
| 24 | tests. | |
| 25 | } | |
| 26 | \examples{ | |
| 27 | is.what(pi) | |
| 28 | is.what(NA, verbose=TRUE) | |
| 29 | is.what(lm(1~1)) | |
| 30 | } | |
| 31 | % Basics | |
| 32 | \keyword{classes} | |
| 33 | \keyword{NA} | |
| 34 | % Programming | |
| 35 | \keyword{programming} | |
| 36 | \keyword{error} | |
| 37 | \keyword{utilities} |
| 0 | \name{keep} | |
| 1 | \alias{keep} | |
| 2 | \title{ | |
| 3 | Remove All Objects, Except Those Specified | |
| 4 | } | |
| 5 | \description{ | |
| 6 | Remove all objects from the default workspace, except those specified. | |
| 7 | } | |
| 8 | \usage{ | |
| 9 | keep(..., list = character(0), sure = FALSE) | |
| 10 | } | |
| 11 | \arguments{ | |
| 12 | \item{...}{objects to be kept, specified one by one, quoted or | |
| 13 | unquoted.} | |
| 14 | \item{list}{character vector of object names to be kept.} | |
| 15 | \item{sure}{whether to perform the removal, otherwise return names of | |
| 16 | objects that would have been removed.} | |
| 17 | } | |
| 18 | \details{ | |
| 19 | Convenient interface to \code{rm()} when removing most objects from | |
| 20 | the default workspace. | |
| 21 | ||
| 22 | Implemented with a few safety caps: objects whose name starts with a | |
| 23 | period \sQuote{\code{.}} are not removed, and \code{sure=TRUE} is | |
| 24 | required to perform the removal. | |
| 25 | } | |
| 26 | \value{ | |
| 27 | A character vector containing object names, or \code{NULL} when | |
| 28 | \code{sure} is \code{TRUE}. | |
| 29 | } | |
| 30 | \author{Arni Magnusson \email{arnima@u.washington.edu}} | |
| 31 | \seealso{ | |
| 32 | \code{\link{rm}}. | |
| 33 | } | |
| 34 | \examples{ | |
| 35 | data(women, cars) | |
| 36 | keep(cars) | |
| 37 | ## To remove all objects except cars, run: | |
| 38 | ## keep(cars, sure=TRUE) | |
| 39 | } | |
| 40 | % Programming | |
| 41 | \keyword{data} | |
| 42 | \keyword{environment} | |
| 43 | \keyword{utilities} |
| 0 | \name{ll} | |
| 1 | \alias{ll} | |
| 2 | \title{ | |
| 3 | Display Information about Objects or Elements | |
| 4 | } | |
| 5 | \description{ | |
| 6 | Display name, class, size, and dimensions of each object in a given | |
| 7 | environment. Alternatively, if the main argument is a list-like | |
| 8 | object, its elements are listed and described. | |
| 9 | } | |
| 10 | \usage{ | |
| 11 | ll(pos=1, unit=c("KB","MB","bytes"), digits=0, dimensions=FALSE, | |
| 12 | function.dim="", sort.elements=FALSE, ...) | |
| 13 | } | |
| 14 | \arguments{ | |
| 15 | \item{pos}{environment position number, environment name, data frame, | |
| 16 | list, model, or any object that \code{is.list()}.} | |
| 17 | \item{unit}{required unit for displaying object size: "bytes", "KB", | |
| 18 | "MB", or first letter.} | |
| 19 | \item{digits}{number of decimals to display when rounding object | |
| 20 | size.} | |
| 21 | \item{dimensions}{whether object dimensions should be returned.} | |
| 22 | \item{function.dim}{value to report as the dimension of function | |
| 23 | objects.} | |
| 24 | \item{sort.elements}{whether elements should be sorted by name.} | |
| 25 | \item{...}{passed to \code{ls()}.} | |
| 26 | } | |
| 27 | \details{ | |
| 28 | A verbose alternative to \code{ls()} and \code{names()}. | |
| 29 | } | |
| 30 | \value{ | |
| 31 | A data frame with named rows and the following columns: | |
| 32 | \item{Class}{object class.} | |
| 33 | \item{KB}{object size \emph{(see notes)}.} | |
| 34 | \item{Dim}{object dimensions \emph{(optional)}.} | |
| 35 | } | |
| 36 | \note{ | |
| 37 | The name of the object size column is the same as the unit used. | |
| 38 | } | |
| 39 | ||
| 40 | \author{Arni Magnusson \email{arnima@u.washington.edu}, with a | |
| 41 | contribution by Jim Rogers | |
| 42 | \email{james\_a\_rogers@groton.pfizer.com}.} | |
| 43 | ||
| 44 | \seealso{ | |
| 45 | \code{\link{ls}} displays names of objects in a given environment. | |
| 46 | ||
| 47 | \code{\link[base]{names}}, \code{\link[utils]{str}}, and | |
| 48 | \code{\link[base]{summary}} display different information about | |
| 49 | list-like elements. | |
| 50 | ||
| 51 | \code{\link{env}} is related to \code{ll}. | |
| 52 | } | |
| 53 | \examples{ | |
| 54 | ll() | |
| 55 | ll(all=TRUE) | |
| 56 | ll("package:base") | |
| 57 | ll("package:base")[ll("package:base")$Class!="function",] | |
| 58 | ||
| 59 | data(infert) | |
| 60 | ll(infert) | |
| 61 | model <- glm(case~spontaneous+induced, family=binomial, data=infert) | |
| 62 | ll(model, dim=TRUE) | |
| 63 | ll(model, sort=TRUE) | |
| 64 | ll(model$family) | |
| 65 | } | |
| 66 | % Basics | |
| 67 | \keyword{data} | |
| 68 | \keyword{attribute} | |
| 69 | \keyword{classes} | |
| 70 | \keyword{list} | |
| 71 | % Programming | |
| 72 | \keyword{environment} | |
| 73 | \keyword{print} | |
| 74 | \keyword{utilities} |
| 0 | \name{matchcols} | |
| 1 | \alias{matchcols} | |
| 2 | \title{Select columns names matching certain critera} | |
| 3 | \description{ | |
| 4 | This function allows easy selection of the column names of an object | |
| 5 | using a set of inclusion and exclusion critera. | |
| 6 | } | |
| 7 | \usage{ | |
| 8 | matchcols(object, with, without, method=c("and","or"), ...) | |
| 9 | } | |
| 10 | \arguments{ | |
| 11 | \item{object}{Matrix or dataframe} | |
| 12 | \item{with, without}{Vector of regular expression patterns} | |
| 13 | \item{method}{One of "and" or "or"} | |
| 14 | \item{\dots}{Optional arguments to \code{grep}} | |
| 15 | } | |
| 16 | \value{ | |
| 17 | Vector of column names which match all (\code{method="and"}) or any | |
| 18 | (\code{method="or"}) of the patterns specified in \code{with}, but | |
| 19 | none of the patterns specified in \code{without}. | |
| 20 | } | |
| 21 | ||
| 22 | \author{Gregory R. Warnes \email{gregory\_r\_warnes@groton.pfizer.com}} | |
| 23 | \seealso{ \code{\link[base]{grep}} } | |
| 24 | \examples{ | |
| 25 | ||
| 26 | # create a matrix with a lot of named columns | |
| 27 | x <- matrix( ncol=30, nrow=5 ) | |
| 28 | colnames(x) <- c("AffyID","Overall Group Means: Control", | |
| 29 | "Overall Group Means: Moderate", | |
| 30 | "Overall Group Means: Marked", | |
| 31 | "Overall Group Means: Severe", | |
| 32 | "Overall Group StdDev: Control", | |
| 33 | "Overall Group StdDev: Moderate", | |
| 34 | "Overall Group StdDev: Marked", | |
| 35 | "Overall Group StdDev: Severe", | |
| 36 | "Overall Group CV: Control", | |
| 37 | "Overall Group CV: Moderate", | |
| 38 | "Overall Group CV: Marked", | |
| 39 | "Overall Group CV: Severe", | |
| 40 | "Overall Model P-value", | |
| 41 | "Overall Model: (Intercept): Estimate", | |
| 42 | "Overall Model: Moderate: Estimate", | |
| 43 | "Overall Model: Marked: Estimate", | |
| 44 | "Overall Model: Severe: Estimate", | |
| 45 | "Overall Model: (Intercept): Std. Error", | |
| 46 | "Overall Model: Moderate: Std. Error", | |
| 47 | "Overall Model: Marked: Std. Error", | |
| 48 | "Overall Model: Severe: Std. Error", | |
| 49 | "Overall Model: (Intercept): t value", | |
| 50 | "Overall Model: Moderate: t value", | |
| 51 | "Overall Model: Marked: t value", | |
| 52 | "Overall Model: Severe: t value", | |
| 53 | "Overall Model: (Intercept): Pr(>|t|)", | |
| 54 | "Overall Model: Moderate: Pr(>|t|)", | |
| 55 | "Overall Model: Marked: Pr(>|t|)", | |
| 56 | "Overall Model: Severe: Pr(>|t|)") | |
| 57 | ||
| 58 | # Get the columns which give estimates or p-values | |
| 59 | # only for marked and severe groups | |
| 60 | matchcols(x, with=c("Pr", "Std. Error"), | |
| 61 | without=c("Intercept","Moderate"), | |
| 62 | method="or" | |
| 63 | ) | |
| 64 | ||
| 65 | # Get just the column which give the p-value for the intercept | |
| 66 | matchcols(x, with=c("Intercept", "Pr") ) | |
| 67 | ||
| 68 | } | |
| 69 | \keyword{manip} |
| 0 | % $Id: nobs.Rd,v 1.6 2005/06/09 14:20:25 nj7w Exp $ | |
| 1 | % | |
| 2 | % $Log: nobs.Rd,v $ | |
| 3 | % Revision 1.6 2005/06/09 14:20:25 nj7w | |
| 4 | % Updating the version number, and various help files to synchronize splitting of gregmisc bundle in 4 individual components. | |
| 5 | % | |
| 6 | % Revision 1.1.1.1 2005/05/25 22:07:33 nj7w | |
| 7 | % Initial entry for individual package gdata | |
| 8 | % | |
| 9 | % Revision 1.5 2002/09/23 13:59:30 warnes | |
| 10 | % - Modified all files to include CVS Id and Log tags. | |
| 11 | % | |
| 12 | % Revision 1.4 2002/03/26 19:29:15 warneg | |
| 13 | % | |
| 14 | % Updated to add ... parameter to function calls. | |
| 15 | % | |
| 16 | % Revision 1.3 2002/02/20 21:31:08 warneg | |
| 17 | % | |
| 18 | % Noted that specialized methods exist. | |
| 19 | % | |
| 20 | % Revision 1.2 2002/02/20 21:29:34 warneg | |
| 21 | % | |
| 22 | % Incorrectly had contents of nobs.R here instead of help text. Corrected. | |
| 23 | % | |
| 24 | % | |
| 25 | ||
| 26 | \name{nobs} | |
| 27 | \alias{nobs} | |
| 28 | \alias{nobs.default} | |
| 29 | \alias{nobs.data.frame} | |
| 30 | \alias{nobs.lm} | |
| 31 | %- Also NEED an `\alias' for EACH other topic documented here. | |
| 32 | \title{ Compute the Number of Non-missing Observations } | |
| 33 | \description{ | |
| 34 | Compute the number of non-missing observations. Special methods exist for | |
| 35 | data frames, and lm objects. | |
| 36 | } | |
| 37 | \usage{ | |
| 38 | nobs(x, ...) | |
| 39 | \method{nobs}{default}(x, ...) | |
| 40 | \method{nobs}{data.frame}(x, ...) | |
| 41 | \method{nobs}{lm}(x, ...) | |
| 42 | } | |
| 43 | \arguments{ | |
| 44 | \item{x}{ Target Object } | |
| 45 | \item{\dots}{ Optional parameters (currently ignored)} | |
| 46 | } | |
| 47 | \details{ | |
| 48 | ||
| 49 | In the simplest case, this is really just wrapper code for | |
| 50 | \code{sum(!is.na(x))}. | |
| 51 | ||
| 52 | } | |
| 53 | \value{ | |
| 54 | A single numeric value or a vector of values (for data.frames) giving | |
| 55 | the number of non-missing values. | |
| 56 | } | |
| 57 | \author{ Gregory R. Warnes \email{gregory\_r\_warnes\@groton.pfizer.com} } | |
| 58 | ||
| 59 | \seealso{ \code{\link{is.na}}, \code{\link{length}} } | |
| 60 | ||
| 61 | \examples{ | |
| 62 | ||
| 63 | x <- c(1,2,3,5,NA,6,7,1,NA ) | |
| 64 | length(x) | |
| 65 | nobs(x) | |
| 66 | ||
| 67 | df <- data.frame(x=rnorm(100), y=rnorm(100)) | |
| 68 | df[1,1] <- NA | |
| 69 | df[1,2] <- NA | |
| 70 | df[2,1] <- NA | |
| 71 | ||
| 72 | nobs(df) | |
| 73 | } | |
| 74 | \keyword{attribute} |
| 0 | \name{read.xls} | |
| 1 | \alias{read.xls} | |
| 2 | \title{Read Excel files} | |
| 3 | \description{Reads a Microsoft Excel file into a data frame} | |
| 4 | \usage{ | |
| 5 | read.xls(xls, sheet=1, verbose=FALSE, ..., perl="perl") | |
| 6 | } | |
| 7 | \arguments{ | |
| 8 | \item{xls}{name of the Microsoft Excel file} | |
| 9 | \item{sheet}{number of sheet within the Excel file from which data are | |
| 10 | to be read} | |
| 11 | \item{verbose}{logical flag indicating whether details should be | |
| 12 | printed as the file is processed.} | |
| 13 | \item{perl}{name of the perl executable to be called.} | |
| 14 | \item{...}{additional arguments to read.table. The defaults of | |
| 15 | read.csv are used.} | |
| 16 | } | |
| 17 | \value{ | |
| 18 | a data frame | |
| 19 | } | |
| 20 | \details{ | |
| 21 | This function works translating the named Microsoft Excel file into a | |
| 22 | temporary .csv file, using Greg Warnes' xls2csv Perl script (installed | |
| 23 | as part of the gregmisc package). | |
| 24 | ||
| 25 | Caution: In the conversion to csv, strings will be quoted. This can be | |
| 26 | problem if you are trying to use the \code{comment.char} option of | |
| 27 | \code{read.table} since the first character of all lines (including | |
| 28 | comment lines) will be "\"" after conversion. | |
| 29 | } | |
| 30 | \references{http://www.analytics.washington.edu/statcomp/downloads/xls2csv} | |
| 31 | \note{ Either a working version of Perl must be present in the executable | |
| 32 | search path, or the exact path of the perl executable must be provided | |
| 33 | via the \code{perl} argument. See the examples below for an illustration.} | |
| 34 | \seealso{ \code{\link[base]{read.csv}} } | |
| 35 | \examples{ | |
| 36 | ||
| 37 | # iris.xls is included in the gregmisc package for use as an example | |
| 38 | xlsfile <- file.path(.path.package('gdata'),'xls','iris.xls') | |
| 39 | xlsfile | |
| 40 | ||
| 41 | iris <- read.xls(xlsfile) | |
| 42 | head(iris) # look at the top few rows | |
| 43 | ||
| 44 | \dontrun{ | |
| 45 | # Example specifying exact Perl path for default MS-Windows install of | |
| 46 | # ActiveState perl | |
| 47 | iris <- read.xls(xlsfile, perl="C:\\perl\bin\perl.exe") | |
| 48 | ||
| 49 | # Example specifying exact Perl path for Unix systems | |
| 50 | iris <- read.xls(xlsfile, perl="/usr/bin/perl") | |
| 51 | } | |
| 52 | } | |
| 53 | \author{Jim Rogers \email{james\_a\_rogers@groton.pfizer.com}, modified | |
| 54 | and extended by Gregory R. Warnes \email{gregory\_r\_warnes@groton.pfizer.com}. | |
| 55 | } | |
| 56 | \keyword{file} |
| 0 | % $Id: rename.vars.Rd,v 1.8 2005/06/09 14:20:25 nj7w Exp $ | |
| 1 | % | |
| 2 | % $Log: rename.vars.Rd,v $ | |
| 3 | % Revision 1.8 2005/06/09 14:20:25 nj7w | |
| 4 | % Updating the version number, and various help files to synchronize splitting of gregmisc bundle in 4 individual components. | |
| 5 | % | |
| 6 | % Revision 1.1.1.1 2005/05/25 22:07:33 nj7w | |
| 7 | % Initial entry for individual package gdata | |
| 8 | % | |
| 9 | % Revision 1.7 2004/04/01 20:23:15 warnes | |
| 10 | % Add function remove.vars(). | |
| 11 | % | |
| 12 | % Revision 1.6 2002/09/23 13:59:30 warnes | |
| 13 | % - Modified all files to include CVS Id and Log tags. | |
| 14 | % | |
| 15 | % | |
| 16 | ||
| 17 | \name{rename.vars} | |
| 18 | \alias{rename.vars} | |
| 19 | \alias{remove.vars} | |
| 20 | \title{Remove or rename variables in a dataframe } | |
| 21 | \description{ | |
| 22 | Remove or rename a variables in a data frame. | |
| 23 | } | |
| 24 | \usage{ | |
| 25 | rename.vars(data, from="", to="", info=TRUE) | |
| 26 | remove.vars(data, names="", info=TRUE) | |
| 27 | } | |
| 28 | \arguments{ | |
| 29 | \item{data}{ dataframe to be modified. } | |
| 30 | \item{from}{ character vector containing the current name of each | |
| 31 | variable to be renamed.} | |
| 32 | \item{to}{ character vector containing the new name of each variable | |
| 33 | to be renamed.} | |
| 34 | \item{names}{ character vector containing the names of variables to be | |
| 35 | removed.} | |
| 36 | \item{info}{ boolean value indicating whether to print details of the | |
| 37 | removal/renaming. Defaults to TRUE.} | |
| 38 | } | |
| 39 | %\details{ | |
| 40 | % ~~ If necessary, more details than the __description__ above ~~ | |
| 41 | %} | |
| 42 | \value{ | |
| 43 | The updated data frame with variables listed in \code{from} renamed to | |
| 44 | the corresponding element of \code{to}. | |
| 45 | } | |
| 46 | \author{Code by Don MacQueen \email{macq\@llnl.gov}. | |
| 47 | Documentation by Gregory R. Warnes | |
| 48 | \email{gregory\_r\_warnes\@groton.pfizer.com} } | |
| 49 | \seealso{ \code{\link{names}}, | |
| 50 | \code{\link{colnames}}, | |
| 51 | \code{\link{data.frame}} | |
| 52 | } | |
| 53 | ||
| 54 | \examples{ | |
| 55 | data <- data.frame(x=1:10,y=1:10,z=1:10) | |
| 56 | names(data) | |
| 57 | data <- rename.vars(data, c("x","y","z"), c("first","second","third")) | |
| 58 | names(data) | |
| 59 | ||
| 60 | data <- remove.vars(data, "second") | |
| 61 | names(data) | |
| 62 | } | |
| 63 | \keyword{ manip } | |
| 64 |
| 0 | % $Id: reorder.Rd,v 1.11 2005/06/09 14:20:26 nj7w Exp $ | |
| 1 | ||
| 2 | ||
| 3 | \name{reorder.factor} | |
| 4 | \alias{reorder.factor} | |
| 5 | \title{Reorder the Levels of a Factor} | |
| 6 | \description{ | |
| 7 | Reorder the levels of a factor | |
| 8 | } | |
| 9 | \usage{ | |
| 10 | \method{reorder}{factor}(x, | |
| 11 | order, | |
| 12 | X, | |
| 13 | FUN, | |
| 14 | sort=mixedsort, | |
| 15 | make.ordered = is.ordered(x), | |
| 16 | ... ) | |
| 17 | } | |
| 18 | \arguments{ | |
| 19 | \item{x}{factor.} | |
| 20 | \item{order}{A vector of indexes or a vector of label names giving the | |
| 21 | order of the new factor levels.} | |
| 22 | \item{X}{auxillary data vector} | |
| 23 | \item{FUN}{function to be applied to subsets of \code{X} determined by | |
| 24 | \code{x}, to determine factor order.} | |
| 25 | \item{sort}{function to use to sort the factor level names} | |
| 26 | \item{make.ordered}{logical value indicating whether the returned | |
| 27 | object should be an \code{'ordered'} factor.} | |
| 28 | \item{...}{Optional parameters to FUN.} | |
| 29 | } | |
| 30 | \details{ | |
| 31 | This function changes the order of the levels of a factor. It can do | |
| 32 | so via three different mechanisms, depending on whether \code{order}, | |
| 33 | \code{X} \emph{and} \code{FUN}, or \code{sort} are provided. | |
| 34 | ||
| 35 | If \code{order} is provided: For a numeric vector, the new factor level names | |
| 36 | are constructed by reordering the factor levels according to the | |
| 37 | numeric values. For vectors, \code{order} gives the list of new factor | |
| 38 | level names. In either case levels omitted from \code{order} will | |
| 39 | become missing values. | |
| 40 | ||
| 41 | If \code{X} \emph{and} \code{Fun} are provided: The data in \code{X} | |
| 42 | is grouped by the levels of \code{data} and \code{FUN} is applied. | |
| 43 | The groups are then sorted by this value, and the resulting order is | |
| 44 | used for the new factor level names. | |
| 45 | ||
| 46 | If \code{sort} is provided (as it is by default): The new | |
| 47 | factor level names are generated by applying the supplied function | |
| 48 | to the existing factor level names. With \code{order="mixedsort"} the | |
| 49 | factor levels are sorted so that combined numeric and character | |
| 50 | strings are sorted in according to character rules on the character | |
| 51 | sections (including ignoring case), and be numeric rules for the | |
| 52 | numeric sections. See \code{mixedsort} for details. | |
| 53 | ||
| 54 | } | |
| 55 | \value{ | |
| 56 | A new factor with the levels ordered as specified. | |
| 57 | } | |
| 58 | ||
| 59 | \author{Gregory R. Warnes \email{Gregory\_R\_Warnes@groton.pfizer.com}} | |
| 60 | ||
| 61 | \seealso{ \code{\link{factor}}, \code{\link[stats]{reorder}} } | |
| 62 | ||
| 63 | \examples{ | |
| 64 | # Create a 4 level example factor | |
| 65 | trt <- factor( sample( c("PLACEBO","300 MG", "600 MG", "1200 MG"), | |
| 66 | 100, replace=TRUE ) ) | |
| 67 | summary(trt) | |
| 68 | # Note that the levels are not in a meaningful order. | |
| 69 | ||
| 70 | library(gtools) | |
| 71 | # Change the order to something useful | |
| 72 | # default "mixedsort" ordering | |
| 73 | trt2 <- reorder(trt) | |
| 74 | summary(trt2) | |
| 75 | # using indexes: | |
| 76 | trt3 <- reorder(trt, c(4,2,3,1)) | |
| 77 | summary(trt3) | |
| 78 | # using label names: | |
| 79 | trt4 <- reorder(trt, c("PLACEBO","300 MG", "600 MG", "1200 MG") ) | |
| 80 | summary(trt4) | |
| 81 | # using frequency | |
| 82 | trt5 <- reorder(trt, X=as.numeric(trt), FUN=length) | |
| 83 | summary(trt5) | |
| 84 | ||
| 85 | ||
| 86 | # drop out the '300 MG' level | |
| 87 | trt6 <- reorder(trt, c("PLACEBO", "600 MG", "1200 MG") ) | |
| 88 | summary(trt6) | |
| 89 | } | |
| 90 | \keyword{ manip } |
| 0 | \name{trim} | |
| 1 | \alias{trim} | |
| 2 | \title{Remove leading and trailing spaces from character strings} | |
| 3 | \description{ | |
| 4 | Remove leading and traling spaces from character strings | |
| 5 | } | |
| 6 | \usage{ | |
| 7 | trim(s) | |
| 8 | } | |
| 9 | \arguments{ | |
| 10 | \item{s}{character string(s) to be processed} | |
| 11 | } | |
| 12 | \value{ | |
| 13 | Elements of \code{s} with all leading and traling spaces removed. | |
| 14 | } | |
| 15 | \author{ Gregory R. Warnes \email{gregory\_r\_warnes@groton.pfizer.com} } | |
| 16 | \seealso{ \code{\link[base]{sub}}, \code{\link[base]{gsub}} } | |
| 17 | \examples{ | |
| 18 | s <- " this is an example string " | |
| 19 | trim(s) | |
| 20 | } | |
| 21 | \keyword{character} |
| 0 | \name{unmatrix} | |
| 1 | \alias{unmatrix} | |
| 2 | \title{Convert a matrix into a vector, with appropriate names} | |
| 3 | \description{ | |
| 4 | Convert a matrix into a vector, with element names constructed from | |
| 5 | the row and column names of the matrix. | |
| 6 | } | |
| 7 | \usage{ | |
| 8 | unmatrix(x, byrow=FALSE) | |
| 9 | } | |
| 10 | \arguments{ | |
| 11 | \item{x}{matrix} | |
| 12 | \item{byrow}{Logical. If \code{FALSE}, the elements within columns will be | |
| 13 | adjacent in the resulting vector, otherwise elements within rows | |
| 14 | will be adjacent.} | |
| 15 | } | |
| 16 | \value{ | |
| 17 | A vector with names constructed from the row and column names from the | |
| 18 | matrix. If the the row or column names are missing, ('r1', 'r2', ..,) or | |
| 19 | ('c1', 'c2', ..) will be used as appropriate. | |
| 20 | } | |
| 21 | \author{Gregory R. Warnes \email{gregory\_r\_warnes@groton.pfizer.com} } | |
| 22 | \seealso{ \code{\link[base]{as.vector}} } | |
| 23 | \examples{ | |
| 24 | # simple, useless example | |
| 25 | m <- matrix( letters[1:10], ncol=5) | |
| 26 | m | |
| 27 | unmatrix(m) | |
| 28 | ||
| 29 | # unroll model output | |
| 30 | x <- rnorm(100) | |
| 31 | y <- rnorm(100, mean=3+5*x, sd=0.25) | |
| 32 | m <- coef( summary(lm( y ~ x )) ) | |
| 33 | unmatrix(m) | |
| 34 | } | |
| 35 | \keyword{manip} | |
| 36 |