PageRenderTime 73ms CodeModel.GetById 35ms RepoModel.GetById 0ms app.codeStats 1ms

/lib/List/Parseable.pm

https://github.com/gitpan/List-Parseable
Perl | 1527 lines | 1234 code | 187 blank | 106 comment | 415 complexity | 98e4b7c593ffd17d041194054c25d2df MD5 | raw file
  1. package List::Parseable;
  2. # Copyright (c) 2008-2010 Sullivan Beck. All rights reserved.
  3. # This program is free software; you can redistribute it and/or modify it
  4. # under the same terms as Perl itself.
  5. ########################################################################
  6. # TODO
  7. ########################################################################
  8. # (type TYPE ELE0 ELE1 ...) extracts elements of the given TYPE
  9. # (istype TYPE ELE0 ELE1 ...) true of all elements are of the given TYPE
  10. ########################################################################
  11. require 5.000;
  12. use warnings;
  13. use Text::Balanced qw(extract_bracketed extract_tagged);
  14. use Sort::DataTypes 3.00 qw(sort_valid_method sort_by_method);
  15. use Storable qw(dclone);
  16. use strict;
  17. our($VERSION);
  18. $VERSION = "1.06";
  19. ########################################################################
  20. # METHODS
  21. ########################################################################
  22. sub new {
  23. my($class,%opts) = @_;
  24. my $self = { "err" => "ignore",
  25. "warn" => "quiet"
  26. };
  27. bless $self,$class;
  28. return $self;
  29. }
  30. sub version {
  31. return $List::Parseable::VERSION;
  32. }
  33. # $self = { err => exit|return|ignore
  34. # warn => stdout|stderr|both|quiet
  35. # }
  36. #
  37. sub errors {
  38. my($self,@opts) = @_;
  39. foreach my $opt (@opts) {
  40. if ($opt eq "exit" ||
  41. $opt eq "return" ||
  42. $opt eq "ignore") {
  43. $$self{"err"} = $opt;
  44. } elsif ($opt eq "stderr" ||
  45. $opt eq "stdout" ||
  46. $opt eq "both" ||
  47. $opt eq "quiet") {
  48. $$self{"warn"} = $opt;
  49. } else {
  50. die "ERROR: invalid error option: $opt\n";
  51. }
  52. }
  53. }
  54. sub list {
  55. my($self,$name,@list) = @_;
  56. $$self{"list"}{$name} = [ @list ];
  57. }
  58. sub string {
  59. my($self,$name,$string) = @_;
  60. my @list = _string($string);
  61. $$self{"list"}{$name} = [ @list ];
  62. }
  63. sub eval {
  64. my($self,$name) = @_;
  65. return _eval($self,@{ $$self{"list"}{$name} });
  66. }
  67. sub vars {
  68. my($self,%hash) = @_;
  69. foreach my $var (keys %hash) {
  70. $$self{"vars"}{$var} = $hash{$var};
  71. }
  72. }
  73. ########################################################################
  74. # LIST PARSING
  75. ########################################################################
  76. sub _eval {
  77. my($self,@list) = @_;
  78. # Step 1 - parse all children
  79. my @tmp;
  80. foreach my $ele (@list) {
  81. if (ref($ele) eq "ARRAY") {
  82. push(@tmp,_eval($self,@$ele));
  83. } elsif (ref($ele)) {
  84. die "ERROR: invalid list element";
  85. } else {
  86. push(@tmp,$ele);
  87. }
  88. }
  89. @list = @tmp;
  90. # Step 2 - separate the list into operations and arguments
  91. my(@ops,@args);
  92. while (@list) {
  93. my $ele = shift(@list);
  94. if (_operation($self,1,$ele)) {
  95. push(@ops,$ele);
  96. } elsif ($ele eq "--") {
  97. @args = @list;
  98. last;
  99. } else {
  100. @args = ($ele,@list);
  101. last;
  102. }
  103. }
  104. # Step 3 - perform operations
  105. while (@ops) {
  106. my $op = pop(@ops);
  107. @args = _operation($self,0,$op,@args);
  108. }
  109. return @args;
  110. }
  111. ########################################################################
  112. # STRING PARSING
  113. ########################################################################
  114. # This parses a string which must contain a single list (though other
  115. # lists may be nested inside it).
  116. #
  117. sub _string {
  118. my($string) = @_;
  119. my(@list);
  120. while ($string) {
  121. next if ($string =~ s/^\s+//);
  122. # Test to make sure that the string consists only of a single list
  123. # and nothing else.
  124. #
  125. # string = "(: (- a-b):foo:bar )"
  126. #
  127. # match = "(- a-b):foo:bar"
  128. # remainder = ""
  129. # eledelim = ":"
  130. my($match,$remainder,$eledelim,$nestedchar) = __string_list($string,1);
  131. if ($match eq "") {
  132. die "ERROR: invalid list string (no list delimiter):\n $string";
  133. }
  134. if ($remainder ne "") {
  135. die "ERROR: invalid list string (remainder):\n $string";
  136. }
  137. $string = "";
  138. # Each element in the list is either a nested list or a scalar element.
  139. while ($match ne "") {
  140. my($m,$r,$d,$n) = ("","","","");
  141. ($m,$r,$d,$n) = __string_list($match,0) if (! $nestedchar);
  142. if ($m ne "") {
  143. # match = "(- a-b ):foo:bar"
  144. #
  145. # m = "(- a-b )"
  146. # r = ":foo:bar"
  147. # d = "-"
  148. if ($r && $eledelim && $r !~ s/^\Q$eledelim\E//) {
  149. die "ERROR: invalid element contains list and scalar:\n $string\n";
  150. }
  151. push(@list,[ _string($m) ]);
  152. $match = $r;
  153. # r = "foo:bar"
  154. # @list = (... [ a, b ])
  155. # match = "foo:bar"
  156. } else {
  157. # match = "foo:bar"
  158. if ($eledelim) {
  159. if ($match =~ s/^(.*?)\Q$eledelim\E//) {
  160. my $val = $1;
  161. $val = "" if (! defined $val);
  162. push(@list,$val);
  163. push(@list,"") if ($match eq "");
  164. } else {
  165. push(@list,$match);
  166. $match = "";
  167. }
  168. } else {
  169. $match =~ s/(\S+)\s*//;
  170. push(@list,$1);
  171. }
  172. }
  173. }
  174. }
  175. return @list;
  176. }
  177. # Finds a list at the start of the string. Extracts it, removes the
  178. # list delimiter (and optional element delimiter), and removes the
  179. # list delimiters from the start and end of the extracted string. It
  180. # returns:
  181. #
  182. # a string containing the list
  183. # the rest (if any) of the string
  184. # the element delimiter
  185. # any special character (\) following the list delimiter
  186. #
  187. sub __string_list {
  188. my($string,$strip) = @_;
  189. my($delim,$nested,$eledelim);
  190. if ($string =~ /^\s*([\050\133\173])(\134)?([[:punct:]]\S*)?/) {
  191. my($delim,$nested,$eledelim) = ($1,$2,$3);
  192. $nested = "" if (! $nested);
  193. $eledelim = "" if (! $eledelim);
  194. $string =~ s/^\s+//;
  195. my($match,$remainder) = extract_bracketed($string,$delim);
  196. if (! defined $match) {
  197. die "ERROR: invalid list string (incomplete list):\n $string";
  198. }
  199. $remainder =~ s/^\s+//;
  200. if ($strip) {
  201. $match =~ s/^\Q$delim$nested$eledelim\E\s*//;
  202. $match =~ s/\s*.$//;
  203. }
  204. return($match,$remainder,$eledelim,$nested);
  205. } else {
  206. return ("");
  207. }
  208. }
  209. ########################################################################
  210. # OPERATIONS
  211. ########################################################################
  212. sub _operation {
  213. my($self,$test,$op,@args) = @_;
  214. #
  215. # Meta operations
  216. #
  217. if ($op eq "scalar") {
  218. return 1 if ($test);
  219. return @args;
  220. } elsif ($op eq "list") {
  221. return 1 if ($test);
  222. return [ @args ];
  223. }
  224. #
  225. # List => scalar operations
  226. #
  227. if ($op eq "count") {
  228. return 1 if ($test);
  229. return $#args+1;
  230. } elsif ($op eq "countval") {
  231. return 1 if ($test);
  232. my $i = 0;
  233. my $val = shift(@args);
  234. foreach my $ele (@args) {
  235. if (ref($ele)) {
  236. return undef if (_error($self,$op,$ele));
  237. } else {
  238. $i++ if ($val eq $ele);
  239. }
  240. }
  241. return $i;
  242. } elsif ($op eq "minval") {
  243. return 1 if ($test);
  244. my $min = $args[0];
  245. foreach my $val (@args) {
  246. if (ref($val)) {
  247. return undef if (_error($self,$op,$val));
  248. } else {
  249. $min = $val if ($val < $min);
  250. }
  251. }
  252. return $min;
  253. } elsif ($op eq "maxval") {
  254. return 1 if ($test);
  255. my $max = $args[0];
  256. foreach my $val (@args) {
  257. if (ref($val)) {
  258. return undef if (_error($self,$op,$val));
  259. } else {
  260. $max = $val if ($val > $max);
  261. }
  262. }
  263. return $max;
  264. } elsif ($op eq "nth") {
  265. return 1 if ($test);
  266. my $n = shift(@args);
  267. if (ref($n) ||
  268. $n !~ /^[-+]?\d+$/ ||
  269. ! _valid_index($n,$#args)) {
  270. _error($self,$op,$n);
  271. return undef;
  272. } else {
  273. return $args[$n];
  274. }
  275. } elsif ($op eq "case") {
  276. return 1 if ($test);
  277. while ($#args > 0) {
  278. my $test = shift(@args);
  279. my $val = shift(@args);
  280. if (ref($test)) {
  281. _error($self,$op,$test);
  282. return undef;
  283. }
  284. return $val if ($test);
  285. }
  286. if (@args) {
  287. return $args[0];
  288. }
  289. return ();
  290. } elsif ($op eq "indexval") {
  291. return 1 if ($test);
  292. my $val = shift(@args);
  293. if (ref($val)) {
  294. _error($self,$op,$val);
  295. return undef;
  296. }
  297. for (my $i=0; $i<=$#args; $i++) {
  298. return $i if (! ref($args[$i]) && $args[$i] eq $val);
  299. }
  300. return -1;
  301. } elsif ($op eq "rindexval") {
  302. return 1 if ($test);
  303. my $val = shift(@args);
  304. if (ref($val)) {
  305. _error($self,$op,$val);
  306. return undef;
  307. }
  308. for (my $i=$#args; $i>=0; $i--) {
  309. return $i if (! ref($args[$i]) && $args[$i] eq $val);
  310. }
  311. return -1;
  312. } elsif ($op eq "join") {
  313. return 1 if ($test);
  314. my $delim;
  315. if ($args[0] eq "delim") {
  316. shift(@args);
  317. $delim = shift(@args);
  318. if ($delim eq "_space_") {
  319. $delim = " ";
  320. } elsif ($delim eq "_null_") {
  321. $delim = "";
  322. } elsif ($delim eq "_tab_") {
  323. $delim = "\t";
  324. } elsif ($delim eq "_nl_") {
  325. $delim = "\n";
  326. }
  327. } else {
  328. $delim = " ";
  329. }
  330. my @list;
  331. foreach my $ele (@args) {
  332. if (ref($ele)) {
  333. return undef if (_error($self,$op,$ele));
  334. } else {
  335. push(@list,$ele);
  336. }
  337. }
  338. return join($delim,@list);
  339. } elsif ($op eq "+" || $op eq "*") {
  340. return 1 if ($test);
  341. my $ret = ($op eq "+" ? 0 : 1);
  342. foreach my $ele (@args) {
  343. if (ref($ele) ||
  344. ! _isnum($ele)) {
  345. return undef if (_error($self,$op,$ele));
  346. } elsif ($op eq "+") {
  347. $ret += $ele;
  348. } else {
  349. $ret *= $ele;
  350. }
  351. }
  352. return $ret;
  353. } elsif ($op eq "-" || $op eq "/") {
  354. return 1 if ($test);
  355. if ($#args != 1 ||
  356. ref($args[0]) ||
  357. ref($args[1]) ||
  358. ! _isnum($args[0]) ||
  359. ! _isnum($args[1])) {
  360. _error($self,$op,\@args);
  361. return undef;
  362. }
  363. if ($op eq "-") {
  364. return $args[0] - $args[1];
  365. } else {
  366. if ($args[1] == 0) {
  367. _error($self,$op,$args[1]);
  368. return undef;
  369. }
  370. return $args[0] / $args[1];
  371. }
  372. }
  373. #
  374. # List => boolean operations
  375. #
  376. if ($op eq "mintrue") {
  377. return 1 if ($test);
  378. my $n = shift(@args);
  379. my $i = 0;
  380. foreach my $ele (@args) {
  381. if (ref($ele)) {
  382. return undef if (_error($self,$op,$ele));
  383. } else {
  384. $i++ if ($ele);
  385. }
  386. }
  387. return 1 if ($i >= $n);
  388. return 0;
  389. } elsif ($op eq "maxtrue") {
  390. return 1 if ($test);
  391. my $n = shift(@args);
  392. my $i = 0;
  393. foreach my $ele (@args) {
  394. if (ref($ele)) {
  395. return undef if (_error($self,$op,$ele));
  396. } else {
  397. $i++ if ($ele);
  398. }
  399. }
  400. return 1 if ($i <= $n);
  401. return 0;
  402. } elsif ($op eq "numtrue") {
  403. return 1 if ($test);
  404. my $n = shift(@args);
  405. my $i = 0;
  406. foreach my $ele (@args) {
  407. if (ref($ele)) {
  408. return undef if (_error($self,$op,$ele));
  409. } else {
  410. $i++ if ($ele);
  411. }
  412. }
  413. return 1 if ($i == $n);
  414. return 0;
  415. } elsif ($op eq "minfalse") {
  416. return 1 if ($test);
  417. my $n = shift(@args);
  418. my $i = 0;
  419. foreach my $ele (@args) {
  420. if (ref($ele)) {
  421. return undef if (_error($self,$op,$ele));
  422. } else {
  423. $i++ if (! $ele);
  424. }
  425. }
  426. return 1 if ($i >= $n);
  427. return 0;
  428. } elsif ($op eq "maxfalse") {
  429. return 1 if ($test);
  430. my $n = shift(@args);
  431. my $i = 0;
  432. foreach my $ele (@args) {
  433. if (ref($ele)) {
  434. return undef if (_error($self,$op,$ele));
  435. } else {
  436. $i++ if (! $ele);
  437. }
  438. }
  439. return 1 if ($i <= $n);
  440. return 0;
  441. } elsif ($op eq "numfalse") {
  442. return 1 if ($test);
  443. my $n = shift(@args);
  444. my $i = 0;
  445. foreach my $ele (@args) {
  446. if (ref($ele)) {
  447. return undef if (_error($self,$op,$ele));
  448. } else {
  449. $i++ if (! $ele);
  450. }
  451. }
  452. return 1 if ($i == $n);
  453. return 0;
  454. } elsif ($op eq "and") {
  455. return 1 if ($test);
  456. return _operation($self,0,"maxfalse",0,@args);
  457. } elsif ($op eq "or") {
  458. return 1 if ($test);
  459. return _operation($self,0,"mintrue",1,@args);
  460. } elsif ($op eq "not") {
  461. return 1 if ($test);
  462. return _operation($self,0,"maxtrue",0,@args);
  463. } elsif ($op eq "member") {
  464. return 1 if ($test);
  465. my $val = shift(@args);
  466. if (ref($val)) {
  467. _error($self,$op,$val);
  468. return undef;
  469. }
  470. foreach my $ele (@args) {
  471. if (ref($ele)) {
  472. return undef if (_error($self,$op,$ele));
  473. } else {
  474. return 1 if ($val eq $ele);
  475. }
  476. }
  477. return 0;
  478. } elsif ($op eq "absent") {
  479. return 1 if ($test);
  480. my $val = shift(@args);
  481. if (ref($val)) {
  482. _error($self,$op,$val);
  483. return undef;
  484. }
  485. foreach my $ele (@args) {
  486. if (ref($ele)) {
  487. return undef if (_error($self,$op,$ele));
  488. } else {
  489. return 0 if ($val eq $ele);
  490. }
  491. }
  492. return 1;
  493. } elsif ($op eq ">") {
  494. return 1 if ($test);
  495. if ($#args != 1 ||
  496. ref($args[0]) ||
  497. ref($args[1]) ||
  498. ! _isnum($args[0]) ||
  499. ! _isnum($args[1])) {
  500. _error($self,$op,\@args);
  501. return undef;
  502. }
  503. return 1 if ($args[0] > $args[1]);
  504. return 0;
  505. } elsif ($op eq ">=") {
  506. return 1 if ($test);
  507. if ($#args != 1 ||
  508. ref($args[0]) ||
  509. ref($args[1]) ||
  510. ! _isnum($args[0]) ||
  511. ! _isnum($args[1])) {
  512. _error($self,$op,\@args);
  513. return undef;
  514. }
  515. return 1 if ($args[0] >= $args[1]);
  516. return 0;
  517. } elsif ($op eq "==") {
  518. return 1 if ($test);
  519. if ($#args != 1 ||
  520. ref($args[0]) ||
  521. ref($args[1]) ||
  522. ! _isnum($args[0]) ||
  523. ! _isnum($args[1])) {
  524. _error($self,$op,\@args);
  525. return undef;
  526. }
  527. return 1 if ($args[0] == $args[1]);
  528. return 0;
  529. } elsif ($op eq "<=") {
  530. return 1 if ($test);
  531. if ($#args != 1 ||
  532. ref($args[0]) ||
  533. ref($args[1]) ||
  534. ! _isnum($args[0]) ||
  535. ! _isnum($args[1])) {
  536. _error($self,$op,\@args);
  537. return undef;
  538. }
  539. return 1 if ($args[0] <= $args[1]);
  540. return 0;
  541. } elsif ($op eq "<") {
  542. return 1 if ($test);
  543. if ($#args != 1 ||
  544. ref($args[0]) ||
  545. ref($args[1]) ||
  546. ! _isnum($args[0]) ||
  547. ! _isnum($args[1])) {
  548. _error($self,$op,\@args);
  549. return undef;
  550. }
  551. return 1 if ($args[0] < $args[1]);
  552. return 0;
  553. } elsif ($op eq "!=") {
  554. return 1 if ($test);
  555. if ($#args != 1 ||
  556. ref($args[0]) ||
  557. ref($args[1]) ||
  558. ! _isnum($args[0]) ||
  559. ! _isnum($args[1])) {
  560. _error($self,$op,\@args);
  561. return undef;
  562. }
  563. return 1 if ($args[0] != $args[1]);
  564. return 0;
  565. } elsif ($op eq "gt") {
  566. return 1 if ($test);
  567. if ($#args != 1 ||
  568. ref($args[0]) ||
  569. ref($args[1])) {
  570. _error($self,$op,\@args);
  571. return undef;
  572. }
  573. return 1 if ($args[0] gt $args[1]);
  574. return 0;
  575. } elsif ($op eq "ge") {
  576. return 1 if ($test);
  577. if ($#args != 1 ||
  578. ref($args[0]) ||
  579. ref($args[1])) {
  580. _error($self,$op,\@args);
  581. return undef;
  582. }
  583. return 1 if ($args[0] ge $args[1]);
  584. return 0;
  585. } elsif ($op eq "eq") {
  586. return 1 if ($test);
  587. if ($#args != 1 ||
  588. ref($args[0]) ||
  589. ref($args[1])) {
  590. _error($self,$op,\@args);
  591. return undef;
  592. }
  593. return 1 if ($args[0] eq $args[1]);
  594. return 0;
  595. } elsif ($op eq "le") {
  596. return 1 if ($test);
  597. if ($#args != 1 ||
  598. ref($args[0]) ||
  599. ref($args[1])) {
  600. _error($self,$op,\@args);
  601. return undef;
  602. }
  603. return 1 if ($args[0] le $args[1]);
  604. return 0;
  605. } elsif ($op eq "lt") {
  606. return 1 if ($test);
  607. if ($#args != 1 ||
  608. ref($args[0]) ||
  609. ref($args[1])) {
  610. _error($self,$op,\@args);
  611. return undef;
  612. }
  613. return 1 if ($args[0] lt $args[1]);
  614. return 0;
  615. } elsif ($op eq "ne") {
  616. return 1 if ($test);
  617. if ($#args != 1 ||
  618. ref($args[0]) ||
  619. ref($args[1])) {
  620. _error($self,$op,\@args);
  621. return undef;
  622. }
  623. return 1 if ($args[0] ne $args[1]);
  624. return 0;
  625. } elsif ($op eq "if") {
  626. return 1 if ($test);
  627. if ($#args < 0 ||
  628. $#args > 2) {
  629. _error($self,$op,\@args);
  630. return undef;
  631. }
  632. my $test = shift(@args);
  633. if (ref($test)) {
  634. _error($self,$op,$test);
  635. return undef;
  636. }
  637. if ($test) {
  638. if (@args) {
  639. return shift(@args);
  640. } else {
  641. return 1;
  642. }
  643. } else {
  644. if ($#args == 1) {
  645. return pop(@args);
  646. } else {
  647. return 0;
  648. }
  649. }
  650. } elsif ($op eq "is_equal") {
  651. return 1 if ($test);
  652. if ($#args != 1 ||
  653. ! ref($args[0]) ||
  654. ! ref($args[1])) {
  655. _error($self,$op,$test);
  656. return undef;
  657. }
  658. my %list1;
  659. foreach my $ele (@{ $args[0] }) {
  660. if (ref($ele)) {
  661. _error($self,$op,$ele);
  662. return undef;
  663. }
  664. $list1{$ele}++;
  665. }
  666. my %list2;
  667. foreach my $ele (@{ $args[1] }) {
  668. if (ref($ele)) {
  669. _error($self,$op,$ele);
  670. return undef;
  671. }
  672. $list2{$ele}++;
  673. }
  674. foreach my $ele (keys %list1) {
  675. return 0 if (! exists $list2{$ele} || $list1{$ele} != $list2{$ele});
  676. }
  677. foreach my $ele (keys %list2) {
  678. return 0 if (! exists $list1{$ele} || $list1{$ele} != $list2{$ele});
  679. }
  680. return 1;
  681. } elsif ($op eq "not_equal") {
  682. return 1 if ($test);
  683. my $val = _operation($self,0,"is_equal",@args);
  684. if (defined $val) {
  685. return ($val ? 0 : 1);
  686. } else {
  687. return undef;
  688. }
  689. } elsif ($op eq "iff") {
  690. return 1 if ($test);
  691. my $t = 0;
  692. my $u = 0;
  693. foreach my $ele (@args) {
  694. if (ref($ele)) {
  695. return undef if (_error($self,$op,$ele));
  696. $u++;
  697. } else {
  698. $t++ if ($ele);
  699. }
  700. }
  701. return 1 if ($t+$u == 0 || $t+$u == $#args + 1);
  702. return 0;
  703. } elsif ($op eq "range" ||
  704. $op eq "rangeL" ||
  705. $op eq "rangeR" ||
  706. $op eq "rangeLR") {
  707. return 1 if ($test);
  708. if ($#args != 2 ||
  709. ref($args[0]) ||
  710. ref($args[1]) ||
  711. ref($args[2]) ||
  712. ! _isnum($args[0]) ||
  713. ! _isnum($args[1]) ||
  714. ! _isnum($args[2]) ||
  715. $args[1] > $args[2]) {
  716. _error($self,$op,[@args]);
  717. }
  718. my($n,$x,$y) = @args;
  719. return 0 if ($n < $x ||
  720. ($n == $x && ($op eq "rangeL" || $op eq "rangeLR")) ||
  721. $n > $y ||
  722. ($n == $y && ($op eq "rangeR" || $op eq "rangeLR")));
  723. return 1;
  724. }
  725. #
  726. # List => list operations
  727. #
  728. if ($op eq "flatten") {
  729. return 1 if ($test);
  730. return _flatten(@args);
  731. } elsif ($op eq "union") {
  732. return 1 if ($test);
  733. my @ret;
  734. foreach my $ele (@args) {
  735. if (ref($ele)) {
  736. push(@ret,@$ele);
  737. } else {
  738. push(@ret,$ele);
  739. }
  740. }
  741. return @ret;
  742. } elsif ($op eq "sort") {
  743. return 1 if ($test);
  744. my @list;
  745. foreach my $ele (@args) {
  746. if (ref($ele)) {
  747. return undef if (_error($self,$op,$ele));
  748. } else {
  749. push(@list,$ele);
  750. }
  751. }
  752. sort_by_method("alphabetic",\@list);
  753. return @list;
  754. } elsif ($op eq "sort_by_method") {
  755. return 1 if ($test);
  756. if (ref($args[0]) ||
  757. ! sort_valid_method($args[0])) {
  758. _error($self,$op,$args[0]);
  759. return undef;
  760. } elsif (! ref($args[1])) {
  761. _error($self,$op,$args[1]);
  762. return undef;
  763. } else {
  764. sort_by_method(@args);
  765. }
  766. return @{ $args[1] };
  767. } elsif ($op eq "unique") {
  768. return 1 if ($test);
  769. my %ele = ();
  770. my @ret = ();
  771. foreach my $ele (_flatten(@args)) {
  772. if (ref($ele)) {
  773. return undef if (_error($self,$op,$ele));
  774. } else {
  775. if (! exists $ele{$ele}) {
  776. push(@ret,$ele);
  777. $ele{$ele} = 1;
  778. }
  779. }
  780. }
  781. return @ret;
  782. } elsif ($op eq "compact") {
  783. return 1 if ($test);
  784. my @ret = ();
  785. foreach my $ele (_flatten(@args)) {
  786. if (ref($ele)) {
  787. return undef if (_error($self,$op,$ele));
  788. } else {
  789. next if (! defined $ele || $ele eq "");
  790. push(@ret,$ele);
  791. }
  792. }
  793. return @ret;
  794. } elsif ($op eq "true") {
  795. return 1 if ($test);
  796. my @ret = ();
  797. foreach my $ele (_flatten(@args)) {
  798. if (ref($ele)) {
  799. return undef if (_error($self,$op,$ele));
  800. } else {
  801. push(@ret,$ele) if ($ele);
  802. }
  803. }
  804. return @ret;
  805. } elsif ($op eq "pop") {
  806. return 1 if ($test);
  807. pop(@args);
  808. return @args;
  809. } elsif ($op eq "shift") {
  810. return 1 if ($test);
  811. shift(@args);
  812. return @args;
  813. } elsif ($op eq "pad") {
  814. return 1 if ($test);
  815. if (ref $args[0] ||
  816. $args[0] !~ /^[-+]?\d+$/) {
  817. return undef if (_error($self,$op,$args[0]));
  818. } else {
  819. my $len = shift(@args);
  820. my @ret;
  821. foreach my $ele (@args) {
  822. if (ref($ele)) {
  823. return undef if (_error($self,$op,$ele));
  824. } else {
  825. my $val = $ele;
  826. if ($len >= 0) {
  827. $val .= " "x($len-length($val));
  828. } else {
  829. $val = " "x(-$len-length($val)) . $val;
  830. }
  831. push(@ret,$val);
  832. }
  833. }
  834. return @ret;
  835. }
  836. } elsif ($op eq "padchar") {
  837. return 1 if ($test);
  838. if (ref($args[0]) ||
  839. $args[0] !~ /^[-+]?\d+$/) {
  840. return undef if (_error($self,$op,$args[0]));
  841. } elsif (ref($args[1]) ||
  842. length($args[1]) != 1) {
  843. return undef if (_error($self,$op,$args[1]));
  844. } else {
  845. my $len = shift(@args);
  846. my $c = shift(@args);
  847. my @ret;
  848. foreach my $ele (@args) {
  849. if (ref($ele)) {
  850. return undef if (_error($self,$op,$ele));
  851. } else {
  852. my $val = $ele;
  853. if ($len >= 0) {
  854. $val .= $c x ($len-length($val));
  855. } else {
  856. $val = $c x (-$len-length($val)) . $val;
  857. }
  858. push(@ret,$val);
  859. }
  860. }
  861. return @ret;
  862. }
  863. } elsif ($op eq "column") {
  864. return 1 if ($test);
  865. my $n = shift(@args);
  866. if (ref($n) ||
  867. $n !~ /^[-+]?\d+$/) {
  868. _error($self,$op,$n);
  869. return undef;
  870. }
  871. my @ret;
  872. foreach my $ele (@args) {
  873. if (! ref($ele)) {
  874. return undef if (_error($self,$op,$ele));
  875. } else {
  876. push(@ret,$$ele[$n]) if (defined $$ele[$n]);
  877. }
  878. }
  879. return @ret;
  880. } elsif ($op eq "reverse") {
  881. return 1 if ($test);
  882. return reverse(@args);
  883. } elsif ($op eq "rotate") {
  884. return 1 if ($test);
  885. my $n = shift(@args);
  886. if (ref($n) || $n !~ /^[-+]?\d+$/) {
  887. _error($self,$op,$n);
  888. return undef;
  889. }
  890. my $dir = 1;
  891. if ($n < 0) {
  892. $dir = 0;
  893. $n *= -1;
  894. }
  895. if ($dir) {
  896. for (my $i=0; $i<$n; $i++) {
  897. push(@args,shift(@args));
  898. }
  899. } else {
  900. for (my $i=0; $i<$n; $i++) {
  901. unshift(@args,pop(@args));
  902. }
  903. }
  904. return @args;
  905. } elsif ($op eq "delete") {
  906. return 1 if ($test);
  907. my $val = shift(@args);
  908. if (ref($val)) {
  909. _error($self,$op,$val);
  910. return undef;
  911. }
  912. my @ret;
  913. foreach my $ele (@args) {
  914. if (ref($ele)) {
  915. return undef if (_error($self,$op,$ele));
  916. } else {
  917. push(@ret,$ele) unless ($ele eq $val);
  918. }
  919. }
  920. return @ret;
  921. } elsif ($op eq "clear") {
  922. return 1 if ($test);
  923. return ();
  924. } elsif ($op eq "append") {
  925. return 1 if ($test);
  926. my $str = shift(@args);
  927. if (ref($str)) {
  928. _error($self,$op,$str);
  929. return undef;
  930. }
  931. my @ret;
  932. foreach my $ele (@args) {
  933. if (ref($ele)) {
  934. return undef if (_error($self,$op,$ele));
  935. } else {
  936. push(@ret,"$ele$str");
  937. }
  938. }
  939. return @ret;
  940. } elsif ($op eq "prepend") {
  941. return 1 if ($test);
  942. my $str = shift(@args);
  943. if (ref($str)) {
  944. _error($self,$op,$str);
  945. return undef;
  946. }
  947. my @ret;
  948. foreach my $ele (@args) {
  949. if (ref($ele)) {
  950. return undef if (_error($self,$op,$ele));
  951. } else {
  952. push(@ret,"$str$ele");
  953. }
  954. }
  955. return @ret;
  956. } elsif ($op eq "splice") {
  957. return 1 if ($test);
  958. my $list = shift(@args);
  959. if (! ref($list)) {
  960. _error($self,$op,$list);
  961. return undef;
  962. }
  963. my @list = @$list;
  964. my $n = shift(@args);
  965. if (ref($n) ||
  966. $n !~ /^[-+]?\d+$/ ||
  967. ! _valid_index($n,$#list)) {
  968. _error($self,$op,$n);
  969. return undef;
  970. }
  971. my $len = shift(@args);
  972. if (ref($len) || $len !~ /^\d+$/) {
  973. _error($self,$op,$len);
  974. return undef;
  975. }
  976. splice(@list,$n,$len,@args);
  977. return @list;
  978. } elsif ($op eq "slice") {
  979. return 1 if ($test);
  980. my $n = shift(@args);
  981. if (ref($n) ||
  982. $n !~ /^[-+]?\d+$/ ||
  983. ! _valid_index($n,$#args - 1)) {
  984. _error($self,$op,$n);
  985. return undef;
  986. }
  987. my $len = shift(@args);
  988. if (ref($len) || $len !~ /^\d+$/) {
  989. _error($self,$op,$len);
  990. return undef;
  991. }
  992. return splice(@args,$n,$len);
  993. } elsif ($op eq "fill") {
  994. return 1 if ($test);
  995. if ($#args < 0 ||
  996. $#args > 3) {
  997. _error($self,$op,\@args);
  998. return undef;
  999. }
  1000. my $list = shift(@args);
  1001. if (! ref($list)) {
  1002. _error($self,$op,$list);
  1003. return undef;
  1004. }
  1005. my @list = @$list;
  1006. my $n;
  1007. if (@args) {
  1008. $n = shift(@args);
  1009. } else {
  1010. $n = 0;
  1011. }
  1012. if (ref($n) || $n !~ /^[-+]?\d+$/) {
  1013. _error($self,$op,$n);
  1014. return undef;
  1015. }
  1016. my $len;
  1017. if (@args) {
  1018. $len = shift(@args);
  1019. if (ref($len) || $len !~ /^[-+]?\d+$/) {
  1020. _error($self,$op,$len);
  1021. return undef;
  1022. }
  1023. return @list if (! $len);
  1024. }
  1025. my $val = "";
  1026. if (@args) {
  1027. $val = shift(@args);
  1028. }
  1029. # Translate (N,LEN) to (X,Y) where X is index of
  1030. # the first element to set and Y is the index of
  1031. # the last element to set, and negative indexes
  1032. # now refer to elements to add on the left.
  1033. my($x,$y);
  1034. if (! defined $len) {
  1035. if ($n < 0) {
  1036. $x = $n + $#list + 1;
  1037. } else {
  1038. $x = $n;
  1039. }
  1040. if ($x < 0) {
  1041. $y = $x;
  1042. } elsif ($x > $#list) {
  1043. $y = $x;
  1044. } else {
  1045. $y = $#list;
  1046. }
  1047. } elsif ($len < 0) {
  1048. if ($n < 0) {
  1049. $y = $n + $#list + 1;
  1050. } else {
  1051. $y = $n;
  1052. }
  1053. $x = $y + $len + 1;
  1054. $len *= -1;
  1055. } else {
  1056. if ($n < 0) {
  1057. $x = $n + $#list + 1;
  1058. } else {
  1059. $x = $n;
  1060. }
  1061. $y = $x + $len - 1;
  1062. }
  1063. # If $x refers to elements left of the list, add them
  1064. # and adjust ($x,$y) accordingly.
  1065. while ($x < 0) {
  1066. unshift(@list,"");
  1067. $x++;
  1068. $y++;
  1069. }
  1070. while ($y > $#list) {
  1071. push(@list,"");
  1072. }
  1073. # Now set the list range to the value.
  1074. if (ref($val)) {
  1075. for (my $i=$x; $i<=$y; $i++) {
  1076. $list[$i] = dclone($val);
  1077. }
  1078. } else {
  1079. for (my $i=$x; $i<=$y; $i++) {
  1080. $list[$i] = $val;
  1081. }
  1082. }
  1083. return @list;
  1084. } elsif ($op eq "difference" || $op eq "d_difference") {
  1085. return 1 if ($test);
  1086. if (! ref($args[0]) ||
  1087. ! ref($args[1])) {
  1088. _error($self,$op,[@args]);
  1089. return undef;
  1090. }
  1091. my @list1 = @{ $args[0] };
  1092. my @list2 = @{ $args[1] };
  1093. my %list2;
  1094. foreach my $ele (@list2) {
  1095. $list2{$ele}++;
  1096. }
  1097. my @ret;
  1098. foreach my $ele (@list1) {
  1099. if ($op eq "difference") {
  1100. push(@ret,$ele) if (! exists $list2{$ele});
  1101. } else {
  1102. if (exists $list2{$ele} && $list2{$ele} > 0) {
  1103. $list2{$ele}--;
  1104. } else {
  1105. push(@ret,$ele);
  1106. }
  1107. }
  1108. }
  1109. return @ret;
  1110. } elsif ($op eq "intersection" || $op eq "d_intersection") {
  1111. return 1 if ($test);
  1112. if (! ref($args[0]) ||
  1113. ! ref($args[1])) {
  1114. _error($self,$op,[@args]);
  1115. return undef;
  1116. }
  1117. my @list1 = @{ $args[0] };
  1118. my @list2 = @{ $args[1] };
  1119. my %list2;
  1120. foreach my $ele (@list2) {
  1121. $list2{$ele}++;
  1122. }
  1123. my @ret;
  1124. foreach my $ele (@list1) {
  1125. if (exists $list2{$ele} && $list2{$ele} > 0) {
  1126. $list2{$ele}--;
  1127. push(@ret,$ele);
  1128. }
  1129. }
  1130. @ret = _operation($self,0,"unique",@ret) if ($op eq "intersection");
  1131. return @ret;
  1132. } elsif ($op eq "symdiff" || $op eq "d_symdiff") {
  1133. return 1 if ($test);
  1134. if (! ref($args[0]) ||
  1135. ! ref($args[1])) {
  1136. _error($self,$op,[@args]);
  1137. return undef;
  1138. }
  1139. my @list1 = @{ $args[0] };
  1140. my @list2 = @{ $args[1] };
  1141. my %list1;
  1142. foreach my $ele (@list1) {
  1143. $list1{$ele}++;
  1144. }
  1145. my %list2;
  1146. foreach my $ele (@list2) {
  1147. $list2{$ele}++;
  1148. }
  1149. my @ret;
  1150. if ($op eq "symdiff") {
  1151. foreach my $ele (@list1) {
  1152. push(@ret,$ele) unless (exists $list2{$ele});
  1153. }
  1154. foreach my $ele (@list2) {
  1155. push(@ret,$ele) unless (exists $list1{$ele});
  1156. }
  1157. @ret = _operation($self,0,"unique",@ret);
  1158. } else {
  1159. foreach my $ele (keys %list1) {
  1160. if (exists $list2{$ele}) {
  1161. my $min = _operation($self,0,"minval",$list1{$ele},$list2{$ele});
  1162. $list1{$ele} -= $min;
  1163. $list2{$ele} -= $min;
  1164. }
  1165. }
  1166. foreach my $ele (@list2) {
  1167. if (exists $list1{$ele}) {
  1168. my $min = _operation($self,0,"minval",$list1{$ele},$list2{$ele});
  1169. $list1{$ele} -= $min;
  1170. $list2{$ele} -= $min;
  1171. }
  1172. }
  1173. foreach my $ele (@list1) {
  1174. push(@ret,$ele), $list1{$ele}-- if ($list1{$ele}>0);
  1175. }
  1176. foreach my $ele (@list2) {
  1177. push(@ret,$ele), $list2{$ele}-- if ($list2{$ele}>0);
  1178. }
  1179. }
  1180. return @ret;
  1181. }
  1182. #
  1183. # Variable operations
  1184. #
  1185. if ($op eq "getvar") {
  1186. return 1 if ($test);
  1187. return undef if ($#args != 0 ||
  1188. ref($args[0]) ||
  1189. ! exists $$self{"vars"}{$args[0]});
  1190. if (ref($$self{"vars"}{$args[0]})) {
  1191. return @{ $$self{"vars"}{$args[0]} };
  1192. } else {
  1193. return $$self{"vars"}{$args[0]};
  1194. }
  1195. } elsif ($op eq "setvar") {
  1196. return 1 if ($test);
  1197. return undef if ($#args != 1 ||
  1198. ref($args[0]));
  1199. $$self{"vars"}{$args[0]} = $args[1];
  1200. return $$self{"vars"}{$args[0]};
  1201. } elsif ($op eq "default") {
  1202. return 1 if ($test);
  1203. return undef if ($#args != 1 ||
  1204. ref($args[0]));
  1205. $$self{"vars"}{$args[0]} = $args[1]
  1206. unless (exists $$self{"vars"}{$args[0]});
  1207. return $$self{"vars"}{$args[0]};
  1208. } elsif ($op eq "unsetvar") {
  1209. return 1 if ($test);
  1210. return undef if ($#args != 0 ||
  1211. ref($args[0]));
  1212. delete $$self{"vars"}{$args[0]} if (exists $$self{"vars"}{$args[0]});
  1213. return undef;
  1214. } elsif ($op eq "pushvar" || $op eq "unshiftvar") {
  1215. return 1 if ($test);
  1216. return undef if ($#args != 1 ||
  1217. ref($args[0]));
  1218. my $var = $args[0];
  1219. if ($op eq "pushvar") {
  1220. if (exists $$self{"vars"}{$var}) {
  1221. if (ref($$self{"vars"}{$var})) {
  1222. push @{ $$self{"vars"}{$var} },$args[1];
  1223. } else {
  1224. $$self{"vars"}{$var} = [ $$self{"vars"}{$var}, $args[1] ];
  1225. }
  1226. } else {
  1227. $$self{"vars"}{$var} = [ $args[1] ];
  1228. }
  1229. } else {
  1230. if (exists $$self{"vars"}{$var}) {
  1231. if (ref($$self{"vars"}{$var})) {
  1232. unshift @{ $$self{"vars"}{$var} },$args[1];
  1233. } else {
  1234. $$self{"vars"}{$var} = [ $args[1], $$self{"vars"}{$var} ];
  1235. }
  1236. } else {
  1237. $$self{"vars"}{$var} = [ $args[1] ];
  1238. }
  1239. }
  1240. return undef;
  1241. } elsif ($op eq "popvar" || $op eq "shiftvar") {
  1242. return 1 if ($test);
  1243. return undef if ($#args != 0 ||
  1244. ref($args[0]) ||
  1245. ! exists $$self{"vars"}{$args[0]} ||
  1246. ! ref($$self{"vars"}{$args[0]}));
  1247. if ($op eq "popvar") {
  1248. return pop @{ $$self{"vars"}{$args[0]} };
  1249. } else {
  1250. return shift @{ $$self{"vars"}{$args[0]} };
  1251. }
  1252. }
  1253. #
  1254. # Error
  1255. #
  1256. return 0 if ($test);
  1257. die "ERROR: impossible error: _operation: $op";
  1258. }
  1259. ########################################################################
  1260. # MISC
  1261. ########################################################################
  1262. sub _flatten {
  1263. my(@list) = @_;
  1264. my @ret = ();
  1265. foreach my $ele (@list) {
  1266. if (ref($ele) eq "ARRAY") {
  1267. push(@ret,_flatten(@$ele));
  1268. } else {
  1269. push(@ret,$ele);
  1270. }
  1271. }
  1272. return @ret;
  1273. }
  1274. # This tests a list index ($n) to see if it is valid for a list
  1275. # containing $length+1 elements (i.e. $#list was passwd in as
  1276. # the second element).
  1277. #
  1278. # List index can go from 0 to $length or -($length+1) to -1.
  1279. #
  1280. sub _valid_index {
  1281. my($n,$length) = @_;
  1282. return 1 if ($n >= 0 && $n <= $length);
  1283. return 1 if ($n >= -($length+1) && $n <= -1);
  1284. return 0;
  1285. }
  1286. sub _ele_to_string {
  1287. my($ele) = @_;
  1288. if (ref($ele)) {
  1289. my @string = ();
  1290. foreach my $e (@$ele) {
  1291. push(@string,_ele_to_string($e));
  1292. }
  1293. return '[ ' . join(" ",@string) . ' ]';
  1294. } else {
  1295. return $ele;
  1296. }
  1297. }
  1298. sub _error {
  1299. my($self,$op,$ele) = @_;
  1300. my $string = _ele_to_string($ele);
  1301. if ($$self{"warn"} eq "stderr" || $$self{"warn"} eq "both") {
  1302. warn "WARNING: invalid argument: $op: $string\n";
  1303. }
  1304. if ($$self{"warn"} eq "stdout" || $$self{"warn"} eq "both") {
  1305. print "WARNING: invalid argument: $op: $string\n";
  1306. }
  1307. exit if ($$self{"err"} eq "exit");
  1308. return 1 if ($$self{"err"} eq "return");
  1309. return 0;
  1310. }
  1311. ########################################################################
  1312. # FROM MY PERSONAL LIBRARIES
  1313. ########################################################################
  1314. sub _isnum {
  1315. my($n,$low,$high)=@_;
  1316. return undef if (! defined $n);
  1317. return 0 if ($n !~ /^\s*([+-]?)\s*(\d+\.?\d*)\s*$/ and
  1318. $n !~ /^\s*([+-]?)\s*(\.\d+)\s*$/);
  1319. $n="$1$2";
  1320. if (defined $low and length($low)>0) {
  1321. return undef if (! _isnum($low));
  1322. return 0 if ($n<$low);
  1323. }
  1324. if (defined $high and length($high)>0) {
  1325. return undef if (! _isnum($high));
  1326. return 0 if ($n>$high);
  1327. }
  1328. return 1;
  1329. }
  1330. 1;
  1331. # Local Variables:
  1332. # mode: cperl
  1333. # indent-tabs-mode: nil
  1334. # cperl-indent-level: 3
  1335. # cperl-continued-statement-offset: 2
  1336. # cperl-continued-brace-offset: 0
  1337. # cperl-brace-offset: 0
  1338. # cperl-brace-imaginary-offset: 0
  1339. # cperl-label-offset: -2
  1340. # End: