Browse Source

Merging in newer Wala stuff.

Brennen Bearnes 10 years ago
parent
commit
f43bf714c0

wala/benchmark.pl → benchmark.pl View File


+ 91
- 116
lib/Wala.pm View File

@@ -1,6 +1,3 @@
1
-#!/usr/bin/perl
2
-# vim:set ts=2 et:
3
-
4 1
 =pod
5 2
 
6 3
 =head1 NAME
@@ -61,8 +58,10 @@ You can set options directly from the calling script, like so:
61 58
         TitleString           => 'wala::', # Display before page names in titles
62 59
         ScriptName            => 'wala.pl',
63 60
         ShowSearchlinks       => 1, # Display "see also" box on pages
61
+        LogRelatedLinks       => 1, # Log related links for a given change.
64 62
         CheckSetup            => 1, # Check for setup files every time
65 63
         UseCache              => 0, # Don't use caching behavior
64
+        NoCache               => qr/^([A-Z]|PageIndex|RecentChanges|HomePage|PageChangeTimes)$/x,
66 65
     );
67 66
 
68 67
     $w->run;
@@ -106,7 +105,8 @@ fault.
106 105
 =head1 REVISION
107 106
 
108 107
  Brennen's version, branched from Brent's at 1.1.4
109
- Last updated Thu Jun  7 13:45:31 PDT 2007
108
+
109
+ $Id: Wala.pm 135 2008-01-27 15:03:47Z bbearnes $
110 110
 
111 111
 =cut
112 112
 
@@ -119,7 +119,7 @@ no  warnings 'uninitialized';
119 119
 use Fcntl qw(:flock);
120 120
 use POSIX qw(strftime);
121 121
 
122
-# Pull in the markup package.
122
+use base 'MethodSpit';
123 123
 use Wala::Markup;
124 124
 use Wala::Editor;
125 125
 
@@ -138,6 +138,9 @@ my %WalaConf = (
138 138
     ShowSearchlinks       => 1, # Display "see also" box on pages
139 139
     CheckSetup            => 1, # Check for setup files every time
140 140
     UseCache              => 0, # Don't use caching behavior
141
+    NoCache               => qr/^([A-Z]|PageIndex|RecentChanges|HomePage
142
+                                  |PageChangeTimes)$/x,
143
+    LogRelatedLinks       => 1, # Log related links for a given change.
141 144
     DisplayRootDir        => undef,
142 145
     DisplayURL            => undef,
143 146
     TestMode              => undef,
@@ -146,69 +149,22 @@ my %WalaConf = (
146 149
     parameters            => undef,
147 150
 );
148 151
 
149
-# The following bits are cheap method generation, in place
150
-# of using Class::Accessor or Object::Tiny.
151
-{
152
-  no strict 'refs';
153
-
154
-  # These are simple accessors.
155
-  foreach my $name (keys %WalaConf) {
156
-    # Install a generated sub:
157
-    *{ $name } = makemethod($name);
158
-  }
159
-
160
-  # These are conditional accessors, dependent on RootDir.
161
-  my %methods_rootdir = (
162
-    LogFile     => 'log',
163
-    SpamLogFile => 'spam.log',
164
-    PagesDir    => 'pages',
165
-    CacheDir    => 'cache',
166
-    DiffDir     => 'diffs',
167
-  );
168
-
169
-  foreach my $name (keys %methods_rootdir) {
170
-    # Install a generated sub:
171
-    *{ $name } = makemethod_rootdir($name, $methods_rootdir{$name});
172
-  }
173
-
174
-}
152
+# (Relatively) cheap custom method generation.
175 153
 
176
-# Handy-dandy basic closure:
177
-sub makemethod {
178
-  my ($name) = @_;
154
+# Simple accessors:
155
+__PACKAGE__->methodspit(keys %WalaConf);
179 156
 
180
-  return sub {
181
-    my ($self, $param) = @_;
182
-    $self->{$name} = $param if $param;
183
-    return $self->{$name};
157
+# Accessors which depend on RootDir unless explicitly set:
158
+__PACKAGE__->methodspit_depend(
159
+  'RootDir',
160
+  {
161
+    LogFile     => '/log',
162
+    SpamLogFile => '/spam.log',
163
+    PagesDir    => '/pages',
164
+    CacheDir    => '/cache',
165
+    DiffDir     => '/diffs',
184 166
   }
185
-}
186
-
187
-# A slightly more complicated closure.
188
-# If we don't have an appropriate value,
189
-# return the RootDir + a default.
190
-#
191
-# This way, if we haven't explicitly set
192
-# something like LogFile, it will always
193
-# be dependent on RootDir.
194
-sub makemethod_rootdir {
195
-  my ($name, $default) = @_;
196
-  
197
-  return sub {
198
-    my $self = shift;
199
-    my ($param) = @_;
200
-
201
-    if (defined $param) {
202
-      $self->{$name} = $param;
203
-    }
204
-
205
-    if (defined $self->{$name}) {
206
-      return $self->{$name};
207
-    } else {
208
-      return $self->RootDir . "/$default";
209
-    }
210
-  }
211
-}
167
+);
212 168
 
213 169
 =head1 METHODS
214 170
 
@@ -247,7 +203,7 @@ sub conf {
247 203
 
248 204
 sub run {
249 205
     my $self = shift;
250
-    my ($query, $result);
206
+    my ($result);
251 207
 
252 208
     my $page = $self->HomePage;
253 209
     $self->setup() if $self->CheckSetup;
@@ -260,9 +216,9 @@ sub run {
260 216
         # We got a plain WikiWord as the only parameter, so that's the page
261 217
         $page = $querystring;
262 218
     } elsif (length($querystring) > 0 or $content_len > 0) {
263
-
264 219
         # We have one or more parameters; read and parse them:
265 220
 
221
+        my $query;
266 222
         if ($content_len > 0) {
267 223
             read STDIN, $query, $content_len;
268 224
         } else {
@@ -273,11 +229,11 @@ sub run {
273 229
     }
274 230
 
275 231
     # Cut off access to other directories.
276
-    if (substr($page, 0, 1) eq '.') {
232
+    if ($page =~ m/^[.]/) {
277 233
         $page = $self->HomePage;
278 234
     }
279 235
 
280
-    my $pagefile = $self->PagesDir . "/$page";
236
+    my $pagefile = $self->PagesDir  . "/$page";
281 237
     my $cachefile = $self->CacheDir . "/$page";
282 238
 
283 239
     print $self->get_header($page);
@@ -296,44 +252,40 @@ sub run {
296 252
     }
297 253
 
298 254
     # Half of caching behavior is implemented starting here:
299
-
300
-    CACHEBREAK: {
301
-      my $usecache = $self->UseCache;
302
-
303
-      if ( $page =~ m/^([A-Z]|PageIndex|RecentChanges|HomePage|
304
-                      PageChangeTimes)$/x ) {
305
-        $usecache = 0;
306
-      }
307
-
308
-      # Why was this localized? Does it matter?
309
-      #local $WalaConf{UseCache} = $usecache;
310
-
311
-      unless ($usecache) {
312
-        print $self->print_page($page) . $self->get_footer($page);
313
-        return 1; # done
314
-      }
255
+    if ($self->skip_cache($page)) {
256
+      print $self->print_page($page) . $self->get_footer($page);
257
+      return 1; # done
315 258
     }
316 259
 
317
-    # Only fall through to this stuff if UseCache is turned on:
260
+    # We'll only fall through to this stuff if UseCache is turned on:
318 261
 
319 262
     my ($page_mtime, $cachetime);
320
-
321 263
     if (-e $cachefile) {
322 264
         ($page_mtime, $cachetime) = get_mtime($pagefile, $cachefile);
323 265
     }
324 266
 
325 267
     # Has the page been touched since it was cached?
326 268
     if ($page_mtime < $cachetime) {
327
-        # use cache
269
+        # no - use cache
328 270
         $result = get_file_text($cachefile);
329 271
     } else {
330
-        # otherwise store a copy in the cache
272
+        # yes - store a fresh copy in the cache
331 273
         $result = $self->print_page($page); 
332 274
         write_file($cachefile, $result);
333 275
     }
334 276
 
335 277
     print $result . $self->get_footer($page);
336
-       
278
+}
279
+
280
+# Skip cache for this page?
281
+sub skip_cache {
282
+  my $self = shift;
283
+  my ($page) = @_;
284
+
285
+  return 1 unless $self->UseCache;
286
+  return 1 if $page =~ $self->NoCache();
287
+
288
+  return;
337 289
 }
338 290
 
339 291
 
@@ -407,7 +359,7 @@ sub convert_links {
407 359
     # Bare links.
408 360
     $text =~ s/(?<![\[<])                                   # not preceded by
409 361
                (http|https|ftp|gopher|news|telnet|ssh):\/\/ # protocol
410
-               [A-Za-z0-9\/\.\-\=\?\&\%\~\_\+#]*            # text
362
+               [A-Za-z0-9\/\.\-=?&%~_+#]*            # text
411 363
               /get_link($&)/geosx;
412 364
 
413 365
 
@@ -464,8 +416,8 @@ sub is_image {
464 416
     if ($url =~ m{^(http:|https:|ftp:)  # protocol
465 417
                   [A-Za-z0-9/.\-=?&%~_+]+
466 418
                   \.(gif|jpg|jpeg|png$) # extensions
467
-                 }ix )
468
-    {
419
+                 }ix
420
+    ) {
469 421
         return 1;
470 422
     } else {
471 423
         return 0;
@@ -488,16 +440,22 @@ sub convert_wikiwords {
488 440
     my ($text) = @_;
489 441
 
490 442
     # CamelCase
491
-    $text =~ s/(?<![A-Za-z0-9\[\=\/\?\.\,\&\-])  # if not preceeded by
492
-               ([A-Z][a-z0-9]+)                  # One uppercase + lowercase
493
-               ([A-Z][a-z0-9]+)+                 # + one uppercase + lowercase
494
-              /$self->wikiword_linkify($&)/geosx;
443
+    $text =~ s/(?<!
444
+                [\w\[=?:] # Not preceeded by a word character, bracket, etc.
445
+               )           
446
+               (
447
+                [A-Z][a-z0-9]+        # One uppercase + lowercase
448
+                (?:[A-Z][a-z0-9]+)+   # + one uppercase + lowercase...
449
+               )
450
+               (\W|$)               # Non-word or EOF
451
+              /$self->wikiword_linkify($1) . $2/geosx;
495 452
 
496 453
     # Bracketed links
497
-    $text =~ s!\[{1,2}                        # one or two brackets
498
-               ([A-Za-z0-9|.%,_'\!\ ]*)         # everything we take in the link
454
+    $text =~ s{(?<! \\)                       # Not an escape.
455
+               \[{1,2}                        # one or two brackets
456
+               ([A-Za-z0-9|.%,_'!\;\&?\= ]*)  # everything we take in the link
499 457
                \]{1,2}                        # one or two brackets
500
-              !$self->wikiword_linkify($1)!geosx;
458
+              }{$self->wikiword_linkify($1)}geosx;
501 459
 
502 460
     return $text;
503 461
 }
@@ -542,7 +500,7 @@ sub write_page {
542 500
 
543 501
     # Check for edit collisions:
544 502
     my $new_timestamp = get_mtime($self->PagesDir . "/$pagename");
545
-    if( $old_timestamp and ($new_timestamp > $old_timestamp) ) {
503
+    if ( $old_timestamp and ($new_timestamp > $old_timestamp) ) {
546 504
         return "<h1>Probable edit collision.</h1>\n\n<p>This page has changed
547 505
                 since you started editing it. You'll find your text below the
548 506
                 edit box - please incorporate your changes here and save the
@@ -565,9 +523,9 @@ sub write_page {
565 523
     my @to_touch;
566 524
 
567 525
     # For new pages we want to update anything that links here:
568
-    if ($diff_line eq 'New page or unchanged.') {
569
-        @to_touch = $self->get_linked_pages($pagename, 0);
570
-    }
526
+    #if ($diff_line eq 'New page or unchanged.') {
527
+        @to_touch = $self->get_linked_pages($pagename);
528
+    #}
571 529
 
572 530
     # Update everything this page links to:
573 531
     push @to_touch, pagelinks($file_text);
@@ -578,7 +536,7 @@ sub write_page {
578 536
     # first mapping directory prefix to the list.
579 537
     my $pagesdir = $self->PagesDir;
580 538
     utime $touch_time, $touch_time,
581
-          map { "${pagesdir}$_" } @to_touch;
539
+          map { "${pagesdir}/$_" } @to_touch;
582 540
 
583 541
     return (0);
584 542
 }
@@ -592,7 +550,7 @@ sub spamcheck {
592 550
 
593 551
     # Does the file contain a URL or an attempt at a URL, and is the user
594 552
     # anonymous?
595
-    if ( ($text =~ m{http://|a href=}i)
553
+    if ( ($text =~ m{http://|a href}i)
596 554
          and $self->get_username eq $self->DefaultUserName )
597 555
     {
598 556
         # Quickie spamlogging.
@@ -793,7 +751,8 @@ sub searchlinks {
793 751
 
794 752
     # Include the list of pages that link to this one.
795 753
     if ( $parameters->{'action'} ne 'links' ) {
796
-        push @matchpages, map { "[$_]" } $self->get_linked_pages($pagename, 15);
754
+        push @matchpages, map { "[$_]" }
755
+                          $self->get_linked_pages($pagename, 15);
797 756
         @matchpages = sort @matchpages;
798 757
 
799 758
         # provide "more..." link if we got a full list.
@@ -803,7 +762,7 @@ sub searchlinks {
803 762
                  '<em>more...</em>');
804 763
         }
805 764
     } else {
806
-        push @matchpages, map { "[$_]" } $self->get_linked_pages($pagename, 0);
765
+        push @matchpages, map { "[$_]" } $self->get_linked_pages($pagename);
807 766
         @matchpages = sort(@matchpages);
808 767
     }
809 768
 
@@ -832,9 +791,19 @@ sub searchlinks {
832 791
     return @result;
833 792
 }
834 793
 
794
+sub format_matchpages {
795
+  my ($link) = @_;
796
+  my $new_link = $link;
797
+  if (length($link) > 20) {
798
+    $new_link = $link . '|' . substr($link, 0, 20) . '...';
799
+  }
800
+  return "[$new_link]";
801
+}
802
+
803
+
804
+# Return a list of the pages that link to a given page
805
+# essentially a big dumb grep:
835 806
 
836
-# return a list of the pages that link to a given page
837
-# essentially a big dumb grep
838 807
 sub get_linked_pages {
839 808
     my $self = shift;
840 809
     my ($pagename, $quantity) = @_;
@@ -857,7 +826,7 @@ sub get_linked_pages {
857 826
     my @matchpages;
858 827
     until ($filename eq '') {
859 828
         # Bail out if we've got a desired quantity:
860
-        last if $quantity and (@matchpages >= $quantity);
829
+        last if (defined $quantity) and (@matchpages >= $quantity);
861 830
 
862 831
         $filename = readdir $dh;
863 832
 
@@ -1376,7 +1345,7 @@ sub parse_cookies {
1376 1345
     
1377 1346
     # see if this works
1378 1347
     my %cookies; 
1379
-    my @values = split /&/, $cookie_string;
1348
+    my @values = split /;/, $cookie_string;
1380 1349
     foreach my $query (@values) {
1381 1350
         my ($name, $value) = split(/=/, $query);
1382 1351
         $value =~ tr/+/ /;
@@ -1650,11 +1619,17 @@ sub write_diff
1650 1619
         $summary = "$change_count changes.";
1651 1620
     }
1652 1621
 
1653
-    # Make sure the links in our related list are unique:
1654
-    my %seen = ();
1655
-    @link_list = grep { ! $seen{$_} ++ } @link_list;
1622
+    if ($self->LogRelatedLinks) {
1656 1623
 
1657
-    if (@link_list) { $summary .= " Related: @link_list"; }
1624
+      # Make sure the links in our related list are unique:
1625
+      my %seen = ();
1626
+      @link_list = map { "[$_]" }
1627
+                   grep { ! $seen{$_} ++ }
1628
+                   @link_list;
1629
+
1630
+      $summary .= ' (Related: ' . (join q{, }, @link_list) . ')'
1631
+        if @link_list; 
1632
+    }
1658 1633
 
1659 1634
     write_file($diffdir . "/$currtime", $the_diff);
1660 1635
 

+ 15
- 0
t/SpitTest.pm View File

@@ -0,0 +1,15 @@
1
+package SpitTest;
2
+
3
+use base 'MethodSpit';
4
+
5
+__PACKAGE__->methodspit( qw( cat ) );
6
+__PACKAGE__->methodspit_depend(
7
+  'cat',
8
+  { moose => 'bark' }
9
+);
10
+
11
+sub new {
12
+  bless { @_ };
13
+}
14
+
15
+1;

+ 12
- 0
t/spittest.pl View File

@@ -0,0 +1,12 @@
1
+use SpitTest;
2
+use Wala;
3
+
4
+my $w = Wala->new();
5
+
6
+my $obj = SpitTest->new();
7
+$obj->cat("Persian ");
8
+print $obj->moose;
9
+$obj->moose("dog");
10
+print $obj->moose;
11
+
12
+print $w->LogFile;

validate.pl → t/validate.pl View File


wala/test.pl → t/wala_test.pl View File


wala/validate.pl → t/wala_validate.pl View File


wala/wala.pl → wala.pl View File


+ 0
- 24
wala/Makefile View File

@@ -1,24 +0,0 @@
1
-all: test docs checkin
2
-
3
-docs: readme test_docs validation_docs
4
-	@echo "Generated text files from POD."
5
-
6
-readme:
7
-	pod2text Wala.pm > README
8
-
9
-test_docs:
10
-	pod2text test.pl > TESTING
11
-
12
-validation_docs:
13
-	pod2text validate.pl > VALIDATION
14
-
15
-test:
16
-	@echo "Running test script."
17
-	./test.pl
18
-	./validate.pl
19
-
20
-checkin: update readme test_docs test
21
-	svn ci
22
-
23
-update:
24
-	svn update

+ 0
- 98
wala/README View File

@@ -1,98 +0,0 @@
1
-NAME
2
-    Wala.pm - easy minimalist wiki
3
-
4
-SYNOPSIS
5
-    As a standalone wiki app:
6
-
7
-        #!/usr/bin/perl
8
-        use Wala;
9
-        my $w = Wala->new;
10
-        $w->run;
11
-
12
-    Pulling content into other scripts:
13
-
14
-        $text = $w->print_page('SandBox');
15
-
16
-DESCRIPTION
17
-    This is a Wala, which is a derivation of a wiki that incorporates
18
-    appending text directly to pages, turning a wiki into something more
19
-    like a forum while retaining all the wonderful full-page editing
20
-    features of a wiki.
21
-
22
-INSTALLATION
23
-    This script is a self-contained package, which makes the code easy to
24
-    test. To actually use it as a wala, create a script named "wala.pl" in
25
-    the same directory, containing the following three lines:
26
-
27
-        #!/usr/bin/perl
28
-        use Wala;
29
-        my $w = Wala->new();
30
-        $w->run;
31
-
32
-    You can experiment with the wala by use'ing it and calling its functions
33
-    without calling "run". By default, required directories and files should
34
-    be created as needed, but you can visit wala.pl?setup in your browser,
35
-    or call "setup()" from a script at any time.
36
-
37
-  CONFIGURATION
38
-    You can set options directly from the calling script, like so:
39
-
40
-        #!/usr/bin/perl
41
-        use Wala;
42
-
43
-        my $w = Wala->new(
44
-            RecentChangesMaxLines => 50,  # Max lines to display in RecentChanges
45
-            DefaultUserName       => 'Anonymous',  # Default user name
46
-            StyleSheet            => 'wala.css',  # URL of style sheet
47
-            DefaultPageText       => "Write something.\n",
48
-            CookieSurvivalDays    => 90,  # Number of days for cookies to remain
49
-            RootDir               => '.', # No trailing slash, please
50
-            HomePage              => 'HomePage', # Name of default page
51
-            TimeZone              => 'UTC', # Currently just a string to display
52
-            TitleString           => 'wala::', # Display before page names in titles
53
-            ScriptName            => 'wala.pl', # substr( $0, rindex( $0, "/" ) + 1 );
54
-            ShowSearchlinks       => 1, # Display "see also" box on pages
55
-            CheckSetup            => 1, # Check for setup files every time
56
-            UseCache              => 0, # Don't use caching behavior
57
-        );
58
-
59
-        $w->run;
60
-
61
-  FEEDS
62
-    Feeds are practically a requirement these days. While it wouldn't be the
63
-    hardest thing in the world to roll my own Atom or RSS within Wala.pm, it
64
-    was much less painful to look to CPAN, which offers
65
-    XML::Atom::SimpleFeed.
66
-
67
-    I've included a simple wala_feed.pl, which relies on the aforementioned
68
-    module. It shouldn't be too hard to customize.
69
-
70
-    If you do something along the lines of:
71
-
72
-        FeedURL => 'http://p1k3.com/wala/wala_feed.pl',
73
-
74
-    in your configuration, Wala.pm will link to your feed in page headers so
75
-    that browsers like Firefox will auto-discover it.
76
-
77
-LICENSE
78
-    No warranty of any kind is made regarding this software's fitness or
79
-    suitability for any purpose. The authors explicitly disclaim any
80
-    liability or responsibility for the results of its use.
81
-
82
-    This software is dedicated to the public domain. In any jurisdiction
83
-    where a dedication to the public domain is not permitted by law, the
84
-    authors grant you a perpetual, non-exclusive license to modify and/or
85
-    redistribute the software in any medium, world-wide, forever and ever.
86
-
87
-    Though there is no legal requirement, credit would be appreciated.
88
-
89
-AUTHORS
90
-    Wala was originally written by Brent P. Newhall. This version contains
91
-    substantial modifications by Brennen Bearnes; following Brent's lead,
92
-    all changes are placed in the public domain. Egregious bugs are probably
93
-    Brennen's fault.
94
-
95
-REVISION
96
-     Brennen's version, branched from Brent's at 1.1.4
97
-     Last updated Thu Jun  7 13:45:31 PDT 2007
98
-

+ 0
- 30
wala/TESTING View File

@@ -1,30 +0,0 @@
1
-NAME
2
-    test.pl - a set of basic tests for Wala.pm
3
-
4
-SYNOPSIS
5
-    Given a working installation and configuration file:
6
-
7
-        ./test.pl
8
-
9
-DESCRIPTION
10
-    This section to-come.
11
-
12
-MISSING TESTS
13
-    These items aren't tested at all, at the moment. A number of them aren't
14
-    particularly trivial to test.
15
-
16
-        sub get_diff
17
-        sub get_latest_diff_date
18
-        sub write_page
19
-        sub add_to_page
20
-        sub log_page_edit
21
-        sub parse_cookies
22
-        sub write_cookies_to_browser
23
-        sub setup
24
-        sub parse_parameters
25
-        sub write_diff
26
-        sub merge_diff
27
-
28
-SEE ALSO
29
-    validate.pl in the WalaWiki distribution.
30
-

+ 0
- 25
wala/VALIDATION View File

@@ -1,25 +0,0 @@
1
-NAME
2
-    validate.pl - W3C validate markup from Wala.pm
3
-
4
-SYNOPSIS
5
-    Given a working installation and configuration file:
6
-
7
-        ./validate.pl
8
-
9
-DESCRIPTION
10
-    These tests are aimed at a working installation with several files in
11
-    place, and require Test::HTML::W3C as well as Test::Simple. For the time
12
-    being, I'm using "valid W3C HTML" as a proxy for "not broken", and a
13
-    number of larger pages as a proxy for their component features. This
14
-    works surprisingly well for much of what the module does.
15
-
16
-    What these tests don't validate in any way is the handling of user
17
-    input, writing of pages, change logging, or edit conflict resolution.
18
-    I'll do something about this, eventually. There are also be some issues
19
-    around testing with different configurations.
20
-
21
-    Nothing here should be destructive.
22
-
23
-SEE ALSO
24
-    test.pl in Wala Wiki distribution, Test::HTML::W3C.
25
-

+ 0
- 39
wala/default.conf.pl View File

@@ -1,39 +0,0 @@
1
-##################
2
-#  WALA OPTIONS  #
3
-##################
4
-
5
-%WalaConf = (
6
-    
7
-    RecentChangesMaxLines => 50,  # Max lines to display in RecentChanges
8
-    DefaultUserName       => 'Anonymous',  # Default user name
9
-    StyleSheet            => 'wala.css',  # URL of style sheet
10
-    DefaultPageText       => "Write something.\n",
11
-    CookieSurvivalDays    => 90,  # Number of days for cookies to remain
12
-    RootDir               => '.', # No trailing slash, please
13
-    HomePage              => 'HomePage', # Name of default page
14
-    TimeZone              => 'UTC', # Currently just a string to display
15
-    TitleString           => 'wala::', # Display before page names in titles
16
-    ScriptName            => 'wala.pl', # substr( $0, rindex( $0, "/" ) + 1 );
17
-    ShowSearchlinks       => 1, # Display "see also" box on pages
18
-    UseCache              => 0, # Don't cache generated pages
19
-
20
-    # Check for important files every time we run the script.
21
-    # This can be changed to 0 for faster load times once everything
22
-    # is working:
23
-    CheckSetup            => 1,
24
-    
25
-    # Uncomment and set to use a feed script:
26
-    #FeedURL               => "http://path/to/wala/feed.pl",
27
-
28
-);
29
-
30
-# Set some important paths relative to our root directory:
31
-$WalaConf{LogFile} = $WalaConf{RootDir} . '/log';
32
-$WalaConf{PagesDir} = $WalaConf{RootDir} . '/pages';
33
-$WalaConf{CacheDir} = $WalaConf{RootDir} . '/cache';
34
-$WalaConf{DiffDir} = $WalaConf{RootDir} . '/diffs';
35
-
36
-# Should be empty unless we're going to use display.pl:
37
-%DISPLAY_CONF = (
38
-);
39
-

+ 0
- 222
wala/lib/Carp/Clan.pm View File

@@ -1,222 +0,0 @@
1
-
2
-##
3
-## Based on Carp.pm from Perl 5.005_03.
4
-## Last modified 12-Jun-2001 by Steffen Beyer.
5
-## Should be reasonably backwards compatible.
6
-##
7
-## This module is free software and can
8
-## be used, modified and redistributed
9
-## under the same terms as Perl itself.
10
-##
11
-
12
-@DB::args = ();    # Avoid warning "used only once" in Perl 5.003
13
-
14
-package Carp::Clan;
15
-
16
-use strict;
17
-use vars qw( $MaxEvalLen $MaxArgLen $MaxArgNums $Verbose $VERSION );
18
-use overload ();
19
-
20
-# Original comments by Andy Wardley <abw@kfs.org> 09-Apr-1998.
21
-
22
-# The $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how
23
-# the eval text and function arguments should be formatted when printed.
24
-
25
-$MaxEvalLen = 0;     # How much eval '...text...' to show. 0 = all.
26
-$MaxArgLen  = 64;    # How much of each argument to print. 0 = all.
27
-$MaxArgNums = 8;     # How many arguments to print.        0 = all.
28
-
29
-$Verbose = 0;        # If true then make _shortmsg call _longmsg instead.
30
-
31
-$VERSION = '5.8';
32
-
33
-# _longmsg() crawls all the way up the stack reporting on all the function
34
-# calls made. The error string, $error, is originally constructed from the
35
-# arguments passed into _longmsg() via confess(), cluck() or _shortmsg().
36
-# This gets appended with the stack trace messages which are generated for
37
-# each function call on the stack.
38
-
39
-sub _longmsg {
40
-    return (@_) if ( ref $_[0] );
41
-    local $_;        # Protect surrounding program - just in case...
42
-    my ( $pack, $file, $line, $sub, $hargs, $eval, $require, @parms, $push );
43
-    my $error = join( '', @_ );
44
-    my $msg   = '';
45
-    my $i     = 0;
46
-    while (
47
-        do {
48
-            {
49
-
50
-                package DB;
51
-                ( $pack, $file, $line, $sub, $hargs, undef, $eval, $require )
52
-                    = caller( $i++ )
53
-            }
54
-        }
55
-        )
56
-    {
57
-        next if ( $pack eq 'Carp::Clan' );
58
-        if ( $error eq '' ) {
59
-            if ( defined $eval ) {
60
-                $eval =~ s/([\\\'])/\\$1/g unless ($require); # Escape \ and '
61
-                $eval
62
-                    =~ s/([\x00-\x1F\x7F-\xFF])/sprintf("\\x%02X",ord($1))/eg;
63
-                substr( $eval, $MaxEvalLen ) = '...'
64
-                    if ( $MaxEvalLen && length($eval) > $MaxEvalLen );
65
-                if ($require) { $sub = "require $eval"; }
66
-                else { $sub = "eval '$eval'"; }
67
-            }
68
-            elsif ( $sub eq '(eval)' ) { $sub = 'eval {...}'; }
69
-            else {
70
-                @parms = ();
71
-                if ($hargs) {
72
-                    $push  = 0;
73
-                    @parms = @DB::args
74
-                        ;    # We may trash some of the args so we take a copy
75
-                    if ( $MaxArgNums and @parms > $MaxArgNums ) {
76
-                        $#parms = $MaxArgNums;
77
-                        pop(@parms);
78
-                        $push = 1;
79
-                    }
80
-                    for (@parms) {
81
-                        if ( defined $_ ) {
82
-                            if ( ref $_ ) {
83
-                                $_ = overload::StrVal($_);
84
-                            }
85
-                            else {
86
-                                unless ( /^-?\d+(?:\.\d+(?:[eE][+-]\d+)?)?$/
87
-                                    )    # Looks numeric
88
-                                {
89
-                                    s/([\\\'])/\\$1/g;    # Escape \ and '
90
-                                    s/([\x00-\x1F\x7F-\xFF])/sprintf("\\x%02X",ord($1))/eg;
91
-                                    substr( $_, $MaxArgLen ) = '...'
92
-                                        if ( $MaxArgLen
93
-                                        and length($_) > $MaxArgLen );
94
-                                    $_ = "'$_'";
95
-                                }
96
-                            }
97
-                        }
98
-                        else { $_ = 'undef'; }
99
-                    }
100
-                    push( @parms, '...' ) if ($push);
101
-                }
102
-                $sub .= '(' . join( ', ', @parms ) . ')';
103
-            }
104
-            if ( $msg eq '' ) { $msg = "$sub called"; }
105
-            else { $msg .= "\t$sub called"; }
106
-        }
107
-        else {
108
-            if ( $sub =~ /::/ ) { $msg = "$sub(): $error"; }
109
-            else { $msg = "$sub: $error"; }
110
-        }
111
-        $msg .= " at $file line $line\n" unless ( $error =~ /\n$/ );
112
-        $error = '';
113
-    }
114
-    $msg ||= $error;
115
-    $msg =~ tr/\0//d;  # Circumvent die's incorrect handling of NUL characters
116
-    $msg;
117
-}
118
-
119
-# _shortmsg() is called by carp() and croak() to skip all the way up to
120
-# the top-level caller's package and report the error from there. confess()
121
-# and cluck() generate a full stack trace so they call _longmsg() to
122
-# generate that. In verbose mode _shortmsg() calls _longmsg() so you
123
-# always get a stack trace.
124
-
125
-sub _shortmsg {
126
-    my $pattern = shift;
127
-    my $verbose = shift;
128
-    return (@_) if ( ref $_[0] );
129
-    goto &_longmsg if ( $Verbose or $verbose );
130
-    my ( $pack, $file, $line, $sub );
131
-    my $error = join( '', @_ );
132
-    my $msg   = '';
133
-    my $i     = 0;
134
-    while ( ( $pack, $file, $line, $sub ) = caller( $i++ ) ) {
135
-        next if ( $pack eq 'Carp::Clan' or $pack =~ /$pattern/ );
136
-        if ( $error eq '' ) { $msg = "$sub() called"; }
137
-        elsif ( $sub =~ /::/ ) { $msg = "$sub(): $error"; }
138
-        else { $msg = "$sub: $error"; }
139
-        $msg .= " at $file line $line\n" unless ( $error =~ /\n$/ );
140
-        $msg =~ tr/\0//d
141
-            ;    # Circumvent die's incorrect handling of NUL characters
142
-        return $msg;
143
-    }
144
-    goto &_longmsg;
145
-}
146
-
147
-# The following four functions call _longmsg() or _shortmsg() depending on
148
-# whether they should generate a full stack trace (confess() and cluck())
149
-# or simply report the caller's package (croak() and carp()), respectively.
150
-# confess() and croak() die, carp() and cluck() warn.
151
-
152
-# Following code kept for calls with fully qualified subroutine names:
153
-# (For backward compatibility with the original Carp.pm)
154
-
155
-sub croak {
156
-    my $callpkg = caller(0);
157
-    my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
158
-    die _shortmsg( $pattern, 0, @_ );
159
-}
160
-sub confess { die _longmsg(@_); }
161
-
162
-sub carp {
163
-    my $callpkg = caller(0);
164
-    my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
165
-    warn _shortmsg( $pattern, 0, @_ );
166
-}
167
-sub cluck { warn _longmsg(@_); }
168
-
169
-# The following method imports a different closure for every caller.
170
-# I.e., different modules can use this module at the same time
171
-# and in parallel and still use different patterns.
172
-
173
-sub import {
174
-    my $pkg     = shift;
175
-    my $callpkg = caller(0);
176
-    my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
177
-    my $verbose = 0;
178
-    my $item;
179
-    my $file;
180
-
181
-    for $item (@_) {
182
-        if ( $item =~ /^\d/ ) {
183
-            if ( $VERSION < $item ) {
184
-                $file = "$pkg.pm";
185
-                $file =~ s!::!/!g;
186
-                $file = $INC{$file};
187
-                die _shortmsg( '^:::', 0,
188
-                    "$pkg $item required--this is only version $VERSION ($file)"
189
-                );
190
-            }
191
-        }
192
-        elsif ( $item =~ /^verbose$/i ) { $verbose = 1; }
193
-        else { $pattern = $item; }
194
-    }
195
-
196
-   # Speed up pattern matching in Perl versions >= 5.005:
197
-   # (Uses "eval ''" because qr// is a syntax error in previous Perl versions)
198
-    if ( $] >= 5.005 ) {
199
-        eval '$pattern = qr/$pattern/;';
200
-    }
201
-    else {
202
-        eval { $pkg =~ /$pattern/; };
203
-    }
204
-    if ($@) {
205
-        $@ =~ s/\s+$//;
206
-        $@ =~ s/\s+at\s.+$//;
207
-        die _shortmsg( '^:::', 0, $@ );
208
-    }
209
-    {
210
-        local ($^W) = 0;
211
-        no strict "refs";
212
-        *{"${callpkg}::croak"}
213
-            = sub { die _shortmsg( $pattern, $verbose, @_ ); };
214
-        *{"${callpkg}::confess"} = sub { die _longmsg(@_); };
215
-        *{"${callpkg}::carp"}
216
-            = sub { warn _shortmsg( $pattern, $verbose, @_ ); };
217
-        *{"${callpkg}::cluck"} = sub { warn _longmsg(@_); };
218
-    }
219
-}
220
-
221
-1;
222
-

+ 0
- 95
wala/lib/Carp/Clan.pod View File

@@ -1,95 +0,0 @@
1
-
2
-=head1 NAME
3
-
4
-Carp::Clan - Report errors from perspective of caller of a "clan" of modules
5
-
6
-=head1 SYNOPSIS
7
-
8
- carp    - warn of errors (from perspective of caller)
9
-
10
- cluck   - warn of errors with stack backtrace
11
-
12
- croak   - die of errors (from perspective of caller)
13
-
14
- confess - die of errors with stack backtrace
15
-
16
-    use Carp::Clan qw(^MyClan::);
17
-    croak "We're outta here!";
18
-
19
-    use Carp::Clan;
20
-    confess "This is how we got here!";
21
-
22
-=head1 DESCRIPTION
23
-
24
-This module is based on "C<Carp.pm>" from Perl 5.005_03. It has been
25
-modified to skip all package names matching the pattern given in
26
-the "use" statement inside the "C<qw()>" term (or argument list).
27
-
28
-Suppose you have a family of modules or classes named "Pack::A",
29
-"Pack::B" and so on, and each of them uses "C<Carp::Clan qw(^Pack::);>"
30
-(or at least the one in which the error or warning gets raised).
31
-
32
-Thus when for example your script "tool.pl" calls module "Pack::A",
33
-and module "Pack::A" calls module "Pack::B", an exception raised in
34
-module "Pack::B" will appear to have originated in "tool.pl" where
35
-"Pack::A" was called, and not in "Pack::A" where "Pack::B" was called,
36
-as the unmodified "C<Carp.pm>" would try to make you believe C<:-)>.
37
-
38
-This works similarly if "Pack::B" calls "Pack::C" where the
39
-exception is raised, etcetera.
40
-
41
-In other words, this blames all errors in the "C<Pack::*>" modules
42
-on the user of these modules, i.e., on you. C<;-)>
43
-
44
-The skipping of a clan (or family) of packages according to a pattern
45
-describing its members is necessary in cases where these modules are
46
-not classes derived from each other (and thus when examining C<@ISA>
47
-- as in the original "C<Carp.pm>" module - doesn't help).
48
-
49
-The purpose and advantage of this is that a "clan" of modules can work
50
-together (and call each other) and throw exceptions at various depths
51
-down the calling hierarchy and still appear as a monolithic block (as
52
-though they were a single module) from the perspective of the caller.
53
-
54
-In case you just want to ward off all error messages from the module
55
-in which you "C<use Carp::Clan>", i.e., if you want to make all error
56
-messages or warnings to appear to originate from where your module
57
-was called (this is what you usually used to "C<use Carp;>" for C<;-)>),
58
-instead of in your module itself (which is what you can do with a
59
-"die" or "warn" anyway), you do not need to provide a pattern,
60
-the module will automatically provide the correct one for you.
61
-
62
-I.e., just "C<use Carp::Clan;>" without any arguments and call "carp"
63
-or "croak" as appropriate, and they will automatically defend your
64
-module against all blames!
65
-
66
-In other words, a pattern is only necessary if you want to make
67
-several modules (more than one) work together and appear as though
68
-they were only one.
69
-
70
-=head2 Forcing a Stack Trace
71
-
72
-As a debugging aid, you can force "C<Carp::Clan>" to treat a "croak" as
73
-a "confess" and a "carp" as a "cluck". In other words, force a detailed
74
-stack trace to be given. This can be very helpful when trying to
75
-understand why, or from where, a warning or error is being generated.
76
-
77
-This feature is enabled either by "importing" the non-existent symbol
78
-'verbose', or by setting the global variable "C<$Carp::Clan::Verbose>"
79
-to a true value.
80
-
81
-You would typically enable it by saying
82
-
83
-    use Carp::Clan qw(verbose);
84
-
85
-Note that you can both specify a "family pattern" and the string "verbose"
86
-inside the "C<qw()>" term (or argument list) of the "use" statement, but
87
-consider that a pattern of packages to skip is pointless when "verbose"
88
-causes a full stack trace anyway.
89
-
90
-=head1 BUGS
91
-
92
-The "C<Carp::Clan>" routines don't handle exception objects currently.
93
-If called with a first argument that is a reference, they simply
94
-call "C<die()>" or "C<warn()>", as appropriate.
95
-

+ 0
- 1848
wala/lib/Test/Builder.pm
File diff suppressed because it is too large
View File


+ 0
- 182
wala/lib/Test/Builder/Module.pm View File

@@ -1,182 +0,0 @@
1
-package Test::Builder::Module;
2
-
3
-use Test::Builder;
4
-
5
-require Exporter;
6
-@ISA = qw(Exporter);
7
-
8
-$VERSION = '0.68';
9
-
10
-use strict;
11
-
12
-# 5.004's Exporter doesn't have export_to_level.
13
-my $_export_to_level = sub {
14
-      my $pkg = shift;
15
-      my $level = shift;
16
-      (undef) = shift;                  # redundant arg
17
-      my $callpkg = caller($level);
18
-      $pkg->export($callpkg, @_);
19
-};
20
-
21
-
22
-=head1 NAME
23
-
24
-Test::Builder::Module - Base class for test modules
25
-
26
-=head1 SYNOPSIS
27
-
28
-  # Emulates Test::Simple
29
-  package Your::Module;
30
-
31
-  my $CLASS = __PACKAGE__;
32
-
33
-  use base 'Test::Builder::Module';
34
-  @EXPORT = qw(ok);
35
-
36
-  sub ok ($;$) {
37
-      my $tb = $CLASS->builder;
38
-      return $tb->ok(@_);
39
-  }
40
-  
41
-  1;
42
-
43
-
44
-=head1 DESCRIPTION
45
-
46
-This is a superclass for Test::Builder-based modules.  It provides a
47
-handful of common functionality and a method of getting at the underlying
48
-Test::Builder object.
49
-
50
-
51
-=head2 Importing
52
-
53
-Test::Builder::Module is a subclass of Exporter which means your
54
-module is also a subclass of Exporter.  @EXPORT, @EXPORT_OK, etc...
55
-all act normally.
56
-
57
-A few methods are provided to do the C<use Your::Module tests => 23> part
58
-for you.
59
-
60
-=head3 import
61
-
62
-Test::Builder::Module provides an import() method which acts in the
63
-same basic way as Test::More's, setting the plan and controling
64
-exporting of functions and variables.  This allows your module to set
65
-the plan independent of Test::More.
66
-
67
-All arguments passed to import() are passed onto 
68
-C<< Your::Module->builder->plan() >> with the exception of 
69
-C<import =>[qw(things to import)]>.
70
-
71
-    use Your::Module import => [qw(this that)], tests => 23;
72
-
73
-says to import the functions this() and that() as well as set the plan
74
-to be 23 tests.
75
-
76
-import() also sets the exported_to() attribute of your builder to be
77
-the caller of the import() function.
78
-
79
-Additional behaviors can be added to your import() method by overriding
80
-import_extra().
81
-
82
-=cut
83
-
84
-sub import {
85
-    my($class) = shift;
86
-
87
-    my $test = $class->builder;
88
-
89
-    my $caller = caller;
90
-
91
-    $test->exported_to($caller);
92
-
93
-    $class->import_extra(\@_);
94
-    my(@imports) = $class->_strip_imports(\@_);
95
-
96
-    $test->plan(@_);
97
-
98
-    $class->$_export_to_level(1, $class, @imports);
99
-}
100
-
101
-
102
-sub _strip_imports {
103
-    my $class = shift;
104
-    my $list  = shift;
105
-
106
-    my @imports = ();
107
-    my @other   = ();
108
-    my $idx = 0;
109
-    while( $idx <= $#{$list} ) {
110
-        my $item = $list->[$idx];
111
-
112
-        if( defined $item and $item eq 'import' ) {
113
-            push @imports, @{$list->[$idx+1]};
114
-            $idx++;
115
-        }
116
-        else {
117
-            push @other, $item;
118
-        }
119
-
120
-        $idx++;
121
-    }
122
-
123
-    @$list = @other;
124
-
125
-    return @imports;
126
-}
127
-
128
-
129
-=head3 import_extra
130
-
131
-    Your::Module->import_extra(\@import_args);
132
-
133
-import_extra() is called by import().  It provides an opportunity for you
134
-to add behaviors to your module based on its import list.
135
-
136
-Any extra arguments which shouldn't be passed on to plan() should be 
137
-stripped off by this method.
138
-
139
-See Test::More for an example of its use.
140
-
141
-B<NOTE> This mechanism is I<VERY ALPHA AND LIKELY TO CHANGE> as it
142
-feels like a bit of an ugly hack in its current form.
143
-
144
-=cut
145
-
146
-sub import_extra {}
147
-
148
-
149
-=head2 Builder
150
-
151
-Test::Builder::Module provides some methods of getting at the underlying
152
-Test::Builder object.
153
-
154
-=head3 builder
155
-
156
-  my $builder = Your::Class->builder;
157
-
158
-This method returns the Test::Builder object associated with Your::Class.
159
-It is not a constructor so you can call it as often as you like.
160
-
161
-This is the preferred way to get the Test::Builder object.  You should
162
-I<not> get it via C<< Test::Builder->new >> as was previously
163
-recommended.
164
-
165
-The object returned by builder() may change at runtime so you should
166
-call builder() inside each function rather than store it in a global.
167
-
168
-  sub ok {
169
-      my $builder = Your::Class->builder;
170
-
171
-      return $builder->ok(@_);
172
-  }
173
-
174
-
175
-=cut
176
-
177
-sub builder {
178
-    return Test::Builder->new;
179
-}
180
-
181
-
182
-1;

+ 0
- 647
wala/lib/Test/Builder/Tester.pm View File

@@ -1,647 +0,0 @@
1
-package Test::Builder::Tester;
2
-
3
-use strict;
4
-use vars qw(@EXPORT $VERSION @ISA);
5
-$VERSION = "1.07";
6
-
7
-use Test::Builder;
8
-use Symbol;
9
-use Carp;
10
-
11
-=head1 NAME
12
-
13
-Test::Builder::Tester - test testsuites that have been built with
14
-Test::Builder
15
-
16
-=head1 SYNOPSIS
17
-
18
-    use Test::Builder::Tester tests => 1;
19
-    use Test::More;
20
-
21
-    test_out("not ok 1 - foo");
22
-    test_fail(+1);
23
-    fail("foo");
24
-    test_test("fail works");
25
-
26
-=head1 DESCRIPTION
27
-
28
-A module that helps you test testing modules that are built with
29
-B<Test::Builder>.
30
-
31
-The testing system is designed to be used by performing a three step
32
-process for each test you wish to test.  This process starts with using
33
-C<test_out> and C<test_err> in advance to declare what the testsuite you
34
-are testing will output with B<Test::Builder> to stdout and stderr.
35
-
36
-You then can run the test(s) from your test suite that call
37
-B<Test::Builder>.  At this point the output of B<Test::Builder> is
38
-safely captured by B<Test::Builder::Tester> rather than being
39
-interpreted as real test output.
40
-
41
-The final stage is to call C<test_test> that will simply compare what you
42
-predeclared to what B<Test::Builder> actually outputted, and report the
43
-results back with a "ok" or "not ok" (with debugging) to the normal
44
-output.
45
-
46
-=cut
47
-
48
-####
49
-# set up testing
50
-####
51
-
52
-my $t = Test::Builder->new;
53
-
54
-###
55
-# make us an exporter
56
-###
57
-
58
-use Exporter;
59
-@ISA = qw(Exporter);
60
-
61
-@EXPORT = qw(test_out test_err test_fail test_diag test_test line_num);
62
-
63
-# _export_to_level and import stolen directly from Test::More.  I am
64
-# the king of cargo cult programming ;-)
65
-
66
-# 5.004's Exporter doesn't have export_to_level.
67
-sub _export_to_level
68
-{
69
-      my $pkg = shift;
70
-      my $level = shift;
71
-      (undef) = shift;                  # XXX redundant arg
72
-      my $callpkg = caller($level);
73
-      $pkg->export($callpkg, @_);
74
-}
75
-
76
-sub import {
77
-    my $class = shift;
78
-    my(@plan) = @_;
79
-
80
-    my $caller = caller;
81
-
82
-    $t->exported_to($caller);
83
-    $t->plan(@plan);
84
-
85
-    my @imports = ();
86
-    foreach my $idx (0..$#plan) {
87
-        if( $plan[$idx] eq 'import' ) {
88
-            @imports = @{$plan[$idx+1]};
89
-            last;
90
-        }
91
-    }
92
-
93
-    __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
94
-}
95
-
96
-###
97
-# set up file handles
98
-###
99
-
100
-# create some private file handles
101
-my $output_handle = gensym;
102
-my $error_handle  = gensym;
103
-
104
-# and tie them to this package
105
-my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT";
106
-my $err = tie *$error_handle,  "Test::Builder::Tester::Tie", "STDERR";
107
-
108
-####
109
-# exported functions
110
-####
111
-
112
-# for remembering that we're testing and where we're testing at
113
-my $testing = 0;
114
-my $testing_num;
115
-
116
-# remembering where the file handles were originally connected
117
-my $original_output_handle;
118
-my $original_failure_handle;
119
-my $original_todo_handle;
120
-
121
-my $original_test_number;
122
-my $original_harness_state;
123
-
124
-my $original_harness_env;
125
-
126
-# function that starts testing and redirects the filehandles for now
127
-sub _start_testing
128
-{
129
-    # even if we're running under Test::Harness pretend we're not
130
-    # for now.  This needed so Test::Builder doesn't add extra spaces
131
-    $original_harness_env = $ENV{HARNESS_ACTIVE} || 0;
132
-    $ENV{HARNESS_ACTIVE} = 0;
133
-
134
-    # remember what the handles were set to
135
-    $original_output_handle  = $t->output();
136
-    $original_failure_handle = $t->failure_output();
137
-    $original_todo_handle    = $t->todo_output();
138
-
139
-    # switch out to our own handles
140
-    $t->output($output_handle);
141
-    $t->failure_output($error_handle);
142
-    $t->todo_output($error_handle);
143
-
144
-    # clear the expected list
145
-    $out->reset();
146
-    $err->reset();
147
-
148
-    # remeber that we're testing
149
-    $testing = 1;
150
-    $testing_num = $t->current_test;
151
-    $t->current_test(0);
152
-
153
-    # look, we shouldn't do the ending stuff
154
-    $t->no_ending(1);
155
-}
156
-
157
-=head2 Functions
158
-
159
-These are the six methods that are exported as default.
160
-
161
-=over 4
162
-
163
-=item test_out
164
-
165
-=item test_err
166
-
167
-Procedures for predeclaring the output that your test suite is
168
-expected to produce until C<test_test> is called.  These procedures
169
-automatically assume that each line terminates with "\n".  So
170
-
171
-   test_out("ok 1","ok 2");
172
-
173
-is the same as
174
-
175
-   test_out("ok 1\nok 2");
176
-
177
-which is even the same as
178
-
179
-   test_out("ok 1");
180
-   test_out("ok 2");
181
-
182
-Once C<test_out> or C<test_err> (or C<test_fail> or C<test_diag>) have
183
-been called once all further output from B<Test::Builder> will be
184
-captured by B<Test::Builder::Tester>.  This means that your will not
185
-be able perform further tests to the normal output in the normal way
186
-until you call C<test_test> (well, unless you manually meddle with the
187
-output filehandles)
188
-
189
-=cut
190
-
191
-sub test_out(@)
192
-{
193
-    # do we need to do any setup?
194
-    _start_testing() unless $testing;
195
-
196
-    $out->expect(@_)
197
-}
198
-
199
-sub test_err(@)
200
-{
201
-    # do we need to do any setup?
202
-    _start_testing() unless $testing;
203
-
204
-    $err->expect(@_)
205
-}
206
-
207
-=item test_fail
208
-
209
-Because the standard failure message that B<Test::Builder> produces
210
-whenever a test fails will be a common occurrence in your test error
211
-output, and because has changed between Test::Builder versions, rather
212
-than forcing you to call C<test_err> with the string all the time like
213
-so
214
-
215
-    test_err("# Failed test ($0 at line ".line_num(+1).")");
216
-
217
-C<test_fail> exists as a convenience function that can be called
218
-instead.  It takes one argument, the offset from the current line that
219
-the line that causes the fail is on.
220
-
221
-    test_fail(+1);
222
-
223
-This means that the example in the synopsis could be rewritten
224
-more simply as:
225
-
226
-   test_out("not ok 1 - foo");
227
-   test_fail(+1);
228
-   fail("foo");
229
-   test_test("fail works");
230
-
231
-=cut
232
-
233
-sub test_fail
234
-{
235
-    # do we need to do any setup?
236
-    _start_testing() unless $testing;
237
-
238
-    # work out what line we should be on
239
-    my ($package, $filename, $line) = caller;
240
-    $line = $line + (shift() || 0); # prevent warnings
241
-
242
-    # expect that on stderr
243
-    $err->expect("#     Failed test ($0 at line $line)");
244
-}
245
-
246
-=item test_diag
247
-
248
-As most of the remaining expected output to the error stream will be
249
-created by Test::Builder's C<diag> function, B<Test::Builder::Tester>
250
-provides a convience function C<test_diag> that you can use instead of
251
-C<test_err>.
252
-
253
-The C<test_diag> function prepends comment hashes and spacing to the
254
-start and newlines to the end of the expected output passed to it and
255
-adds it to the list of expected error output.  So, instead of writing
256
-
257
-   test_err("# Couldn't open file");
258
-
259
-you can write
260
-
261
-   test_diag("Couldn't open file");
262
-
263
-Remember that B<Test::Builder>'s diag function will not add newlines to
264
-the end of output and test_diag will. So to check
265
-
266
-   Test::Builder->new->diag("foo\n","bar\n");
267
-
268
-You would do
269
-
270
-  test_diag("foo","bar")
271
-
272
-without the newlines.
273
-
274
-=cut
275
-
276
-sub test_diag
277
-{
278
-    # do we need to do any setup?
279
-    _start_testing() unless $testing;
280
-
281
-    # expect the same thing, but prepended with "#     "
282
-    local $_;
283
-    $err->expect(map {"# $_"} @_)
284
-}
285
-
286
-=item test_test
287
-
288
-Actually performs the output check testing the tests, comparing the
289
-data (with C<eq>) that we have captured from B<Test::Builder> against
290
-that that was declared with C<test_out> and C<test_err>.
291
-
292
-This takes name/value pairs that effect how the test is run.
293
-
294
-=over
295
-
296
-=item title (synonym 'name', 'label')
297
-
298
-The name of the test that will be displayed after the C<ok> or C<not
299
-ok>.
300
-
301
-=item skip_out
302
-
303
-Setting this to a true value will cause the test to ignore if the
304
-output sent by the test to the output stream does not match that
305
-declared with C<test_out>.
306
-
307
-=item skip_err
308
-
309
-Setting this to a true value will cause the test to ignore if the
310
-output sent by the test to the error stream does not match that
311
-declared with C<test_err>.
312
-
313
-=back
314
-
315
-As a convience, if only one argument is passed then this argument
316
-is assumed to be the name of the test (as in the above examples.)
317
-
318
-Once C<test_test> has been run test output will be redirected back to
319
-the original filehandles that B<Test::Builder> was connected to
320
-(probably STDOUT and STDERR,) meaning any further tests you run
321
-will function normally and cause success/errors for B<Test::Harness>.
322
-
323
-=cut
324
-
325
-sub test_test
326
-{
327
-   # decode the arguements as described in the pod
328
-   my $mess;
329
-   my %args;
330
-   if (@_ == 1)
331
-     { $mess = shift }
332
-   else
333
-   {
334
-     %args = @_;
335
-     $mess = $args{name} if exists($args{name});
336
-     $mess = $args{title} if exists($args{title});
337
-     $mess = $args{label} if exists($args{label});
338
-   }
339
-
340
-    # er, are we testing?
341
-    croak "Not testing.  You must declare output with a test function first."
342
-	unless $testing;
343
-
344
-    # okay, reconnect the test suite back to the saved handles
345
-    $t->output($original_output_handle);
346
-    $t->failure_output($original_failure_handle);
347
-    $t->todo_output($original_todo_handle);
348
-
349
-    # restore the test no, etc, back to the original point
350
-    $t->current_test($testing_num);
351
-    $testing = 0;
352
-
353
-    # re-enable the original setting of the harness
354
-    $ENV{HARNESS_ACTIVE} = $original_harness_env;
355
-
356
-    # check the output we've stashed
357
-    unless ($t->ok(    ($args{skip_out} || $out->check)
358
-                    && ($args{skip_err} || $err->check),
359
-                   $mess))
360
-    {
361
-      # print out the diagnostic information about why this
362
-      # test failed
363
-
364
-      local $_;
365
-
366
-      $t->diag(map {"$_\n"} $out->complaint)
367
-	unless $args{skip_out} || $out->check;
368
-
369
-      $t->diag(map {"$_\n"} $err->complaint)
370
-	unless $args{skip_err} || $err->check;
371
-    }
372
-}
373
-
374
-=item line_num
375
-
376
-A utility function that returns the line number that the function was
377
-called on.  You can pass it an offset which will be added to the
378
-result.  This is very useful for working out the correct text of
379
-diagnostic functions that contain line numbers.
380
-
381
-Essentially this is the same as the C<__LINE__> macro, but the
382
-C<line_num(+3)> idiom is arguably nicer.
383
-
384
-=cut
385
-
386
-sub line_num
387
-{
388
-    my ($package, $filename, $line) = caller;
389
-    return $line + (shift() || 0); # prevent warnings
390
-}
391
-
392
-=back
393
-
394
-In addition to the six exported functions there there exists one
395
-function that can only be accessed with a fully qualified function
396
-call.
397
-
398
-=over 4
399
-
400
-=item color
401
-
402
-When C<test_test> is called and the output that your tests generate
403
-does not match that which you declared, C<test_test> will print out
404
-debug information showing the two conflicting versions.  As this
405
-output itself is debug information it can be confusing which part of
406
-the output is from C<test_test> and which was the original output from
407
-your original tests.  Also, it may be hard to spot things like
408
-extraneous whitespace at the end of lines that may cause your test to
409
-fail even though the output looks similar.
410
-
411
-To assist you, if you have the B<Term::ANSIColor> module installed
412
-(which you should do by default from perl 5.005 onwards), C<test_test>
413
-can colour the background of the debug information to disambiguate the
414
-different types of output. The debug output will have it's background
415
-coloured green and red.  The green part represents the text which is
416
-the same between the executed and actual output, the red shows which
417
-part differs.
418
-
419
-The C<color> function determines if colouring should occur or not.
420
-Passing it a true or false value will enable or disable colouring
421
-respectively, and the function called with no argument will return the
422
-current setting.
423
-
424
-To enable colouring from the command line, you can use the
425
-B<Text::Builder::Tester::Color> module like so:
426
-
427
-   perl -Mlib=Text::Builder::Tester::Color test.t
428
-
429
-Or by including the B<Test::Builder::Tester::Color> module directly in
430
-the PERL5LIB.
431
-
432
-=cut
433
-
434
-my $color;
435
-sub color
436
-{
437
-  $color = shift if @_;
438
-  $color;
439
-}
440
-
441
-=back
442
-
443
-=head1 BUGS
444
-
445
-Calls C<<Test::Builder->no_ending>> turning off the ending tests.
446
-This is needed as otherwise it will trip out because we've run more
447
-tests than we strictly should have and it'll register any failures we
448
-had that we were testing for as real failures.
449
-
450
-The color function doesn't work unless B<Term::ANSIColor> is installed
451
-and is compatible with your terminal.
452
-
453
-Bugs (and requests for new features) can be reported to the author
454
-though the CPAN RT system:
455
-L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Builder-Tester>
456
-
457
-=head1 AUTHOR
458
-
459
-Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
460
-
461
-Some code taken from B<Test::More> and B<Test::Catch>, written by by
462
-Michael G Schwern E<lt>schwern@pobox.comE<gt>.  Hence, those parts
463
-Copyright Micheal G Schwern 2001.  Used and distributed with
464
-permission.
465
-
466
-This program is free software; you can redistribute it
467
-and/or modify it under the same terms as Perl itself.
468
-
469
-=head1 NOTES
470
-
471
-This code has been tested explicitly on the following versions
472
-of perl: 5.7.3, 5.6.1, 5.6.0, 5.005_03, 5.004_05 and 5.004.
473
-
474
-Thanks to Richard Clamp E<lt>richardc@unixbeard.netE<gt> for letting
475
-me use his testing system to try this module out on.
476
-
477
-=head1 SEE ALSO
478
-
479
-L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>.
480
-
481
-=cut
482
-
483
-1;
484
-
485
-####################################################################
486
-# Helper class that is used to remember expected and received data
487
-
488
-package Test::Builder::Tester::Tie;
489
-
490
-##
491
-# add line(s) to be expected
492
-
493
-sub expect
494
-{
495
-    my $self = shift;
496
-
497
-    my @checks = @_;
498
-    foreach my $check (@checks) {
499
-        $check = $self->_translate_Failed_check($check);
500
-        push @{$self->{wanted}}, ref $check ? $check : "$check\n";
501
-    }
502
-}
503
-
504
-
505
-sub _translate_Failed_check
506
-{
507
-    my($self, $check) = @_;
508
-
509
-    if( $check =~ /\A(.*)#     (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) {
510
-        $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/";
511
-    }
512
-
513
-    return $check;
514
-}
515
-
516
-
517
-##
518
-# return true iff the expected data matches the got data
519
-
520
-sub check
521
-{
522
-    my $self = shift;
523
-
524
-    # turn off warnings as these might be undef
525
-    local $^W = 0;
526
-
527
-    my @checks = @{$self->{wanted}};
528
-    my $got = $self->{got};
529
-    foreach my $check (@checks) {
530
-        $check = "\Q$check\E" unless ($check =~ s,^/(.*)/$,$1, or ref $check);
531
-        return 0 unless $got =~ s/^$check//;
532
-    }
533
-
534
-    return length $got == 0;
535
-}
536
-
537
-##
538
-# a complaint message about the inputs not matching (to be
539
-# used for debugging messages)
540
-
541
-sub complaint
542
-{
543
-    my $self = shift;
544
-    my $type   = $self->type;
545
-    my $got    = $self->got;
546
-    my $wanted = join "\n", @{$self->wanted};
547
-
548
-    # are we running in colour mode?
549
-    if (Test::Builder::Tester::color)
550
-    {
551
-      # get color
552
-      eval "require Term::ANSIColor";
553
-      unless ($@)
554
-      {
555
-	# colours
556
-
557
-	my $green = Term::ANSIColor::color("black").
558
-	            Term::ANSIColor::color("on_green");
559
-        my $red   = Term::ANSIColor::color("black").
560
-                    Term::ANSIColor::color("on_red");
561
-	my $reset = Term::ANSIColor::color("reset");
562
-
563
-	# work out where the two strings start to differ
564
-	my $char = 0;
565
-	$char++ while substr($got, $char, 1) eq substr($wanted, $char, 1);
566
-
567
-	# get the start string and the two end strings
568
-	my $start     = $green . substr($wanted, 0,   $char);
569
-	my $gotend    = $red   . substr($got   , $char) . $reset;
570
-	my $wantedend = $red   . substr($wanted, $char) . $reset;
571
-
572
-	# make the start turn green on and off
573
-	$start =~ s/\n/$reset\n$green/g;
574
-
575
-	# make the ends turn red on and off
576
-	$gotend    =~ s/\n/$reset\n$red/g;
577
-	$wantedend =~ s/\n/$reset\n$red/g;
578
-
579
-	# rebuild the strings
580
-	$got    = $start . $gotend;
581
-	$wanted = $start . $wantedend;
582
-      }
583
-    }
584
-
585
-    return "$type is:\n" .
586
-           "$got\nnot:\n$wanted\nas expected"
587
-}
588
-
589
-##
590
-# forget all expected and got data
591
-
592
-sub reset
593
-{
594
-    my $self = shift;
595
-    %$self = (
596
-              type   => $self->{type},
597
-              got    => '',
598
-              wanted => [],
599
-             );
600
-}
601
-
602
-
603
-sub got
604
-{
605
-    my $self = shift;
606
-    return $self->{got};
607
-}
608
-
609
-sub wanted
610
-{
611
-    my $self = shift;
612
-    return $self->{wanted};
613
-}
614
-
615
-sub type
616
-{
617
-    my $self = shift;
618
-    return $self->{type};
619
-}
620
-
621
-###
622
-# tie interface
623
-###
624
-
625
-sub PRINT  {
626
-    my $self = shift;
627
-    $self->{got} .= join '', @_;
628
-}
629
-
630
-sub TIEHANDLE {
631
-    my($class, $type) = @_;
632
-
633
-    my $self = bless {
634
-                   type => $type
635
-               }, $class;
636
-
637
-    $self->reset;
638
-
639
-    return $self;
640
-}
641
-
642
-sub READ {}
643
-sub READLINE {}
644
-sub GETC {}
645
-sub FILENO {}
646
-
647
-1;

+ 0
- 50
wala/lib/Test/Builder/Tester/Color.pm View File

@@ -1,50 +0,0 @@
1
-package Test::Builder::Tester::Color;
2
-
3
-use strict;
4
-
5
-require Test::Builder::Tester;
6
-
7
-=head1 NAME
8
-
9
-Test::Builder::Tester::Color - turn on colour in Test::Builder::Tester
10
-
11
-=head1 SYNOPSIS
12
-
13
-   When running a test script
14
-
15
-     perl -MTest::Builder::Tester::Color test.t
16
-
17
-=head1 DESCRIPTION
18
-
19
-Importing this module causes the subroutine color in Test::Builder::Tester
20
-to be called with a true value causing colour highlighting to be turned
21
-on in debug output.
22
-
23
-The sole purpose of this module is to enable colour highlighting
24
-from the command line.
25
-
26
-=cut
27
-
28
-sub import
29
-{
30
-    Test::Builder::Tester::color(1);
31
-}
32
-
33
-=head1 AUTHOR
34
-
35
-Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002.
36
-
37
-This program is free software; you can redistribute it
38
-and/or modify it under the same terms as Perl itself.
39
-
40
-=head1 BUGS
41
-
42
-This module will have no effect unless Term::ANSIColor is installed.
43
-
44
-=head1 SEE ALSO
45
-
46
-L<Test::Builder::Tester>, L<Term::ANSIColor>
47
-
48
-=cut
49
-
50
-1;

+ 0
- 275
wala/lib/Test/HTML/W3C.pm View File

@@ -1,275 +0,0 @@
1
-package Test::HTML::W3C;
2
-
3
-use strict;
4
-use vars qw($VERSION @EXPORT);
5
-$VERSION = "0.02"; 
6
-
7
-=head1 NAME
8
-
9
-Test::HTML::W3C - Perform W3C HTML validation testing
10
-
11
-=head1 SYNOPSIS
12
-
13
-  use Test::W3C::HTML tests => $test_count;
14
-  # or
15
-  use Test::W3C::HTML 'show_detail';
16
-  # or when using both
17
-  use Test::W3C::HTML tests => $test_count, 'show_detail';
18
-
19
-  is_valid_markup($my_html_scalar);
20
-
21
-  is_valid_file("/path/to/my/file.html");
22
-
23
-  is_valid("http://example.com");
24
-
25
-  # Get the underlying WebService:;Validator::W3C::HTML object
26
-  my $validator = validator();
27
-
28
-=head1 DESCRIPTION
29
-
30
-The purpose of this module is to provide a wide range of testing
31
-utilities.  Various ways to say "ok" with better diagnostics,
32
-facilities to skip tests, test future features and compare complicated
33
-data structures.  While you can do almost anything with a simple
34
-C<ok()> function, it doesn't provide good diagnostic output.
35
-
36
-=head1 ABUSE
37
-
38
-Please keep in mind that the W3C validation pages and services are
39
-a shared resource. If you plan to do many many tests, please consider
40
-using your own installation of the validation programs, and then use
41
-your local install by modifying the local validtor:
42
-
43
-  my $v = validator();
44
-  $v->validator_uri($my_own_validator);
45
-
46
-See the documentation for WebService:;Validator::W3C::HTML and the W3C's
47
-site at http://validator.w3.org/ for details
48
-
49
-=over 4
50
-
51
-=cut
52
-
53
-use WebService::Validator::HTML::W3C;
54
-use base qw(Test::Builder::Module);
55
-@EXPORT = qw(
56
-             plan
57
-             diag_html
58
-             is_valid_markup
59
-             is_valid_file
60
-             is_valid
61
-             validator
62
-            );
63
-
64
-my $v = WebService::Validator::HTML::W3C->new();
65
-my $not_checked = 1;
66
-my $show_detail = 0;
67
-
68
-sub import_extra {
69
-    my ($class, $list) = @_;
70
-    my @other = ();
71
-    my $idx = 0;
72
-    while( $idx <= $#{$list} ) {
73
-        my $item = $list->[$idx];
74
-
75
-        if( defined $item and $item eq 'show_detail' ) {
76
-            $show_detail = 1;
77
-            $v = WebService::Validator::HTML::W3C->new(detailed => 1);
78
-        } else {
79
-            push @other, $item;
80
-        }
81
-        $idx++;
82
-    }
83
-    @$list = @other;
84
-}
85
-
86
-=item validator();
87
-
88
-B<Description:> Returns the underlying WebService::Validator::HTML::W3C object
89
-
90
-B<Parameters:> None.
91
-
92
-B<Returns:> $validator
93
-
94
-=cut
95
-
96
-sub validator {
97
-    return $v;
98
-}
99
-
100
-
101
-=item plan();
102
-
103
-B<Description:> Returns the underlying WebService::Validator::HTML::W3C object
104
-
105
-B<Parameters:> None.
106
-
107
-B<Returns:> $validator
108
-
109
-=cut
110
-
111
-sub plan {
112
-    __PACKAGE__->builder->plan(@_);
113
-}
114
-
115
-sub _check_plan {
116
-    $not_checked = 0;
117
-    if (! __PACKAGE__->builder->has_plan()) {
118
-        plan("no_plan");
119
-    }
120
-}
121
-
122
-=item is_valid_markup($markup[, $name]);
123
-
124
-B<Description:> is_valid_markup tests whether the text in the provided scalar
125
-value correctly validates according to the W3C specifications. This is useful
126
-if you have markup stored in a scalar that you wish to test that  you might get
127
-from using LWP or WWW::Mechanize for example...
128
-
129
-B<Parameters:> $markup, a scalar containing the data to test, $name, an
130
-optional descriptive test name.
131
-
132
-B<Returns:> None.
133
-
134
-=cut
135
-
136
-sub is_valid_markup {
137
-    _check_plan() if $not_checked;
138
-    my ($markup, $message) = @_;
139
-    if ($v->validate_markup($markup)) {
140
-        _result($v, $message);
141
-    } else {
142
-        _validator_err($v, "markup");
143
-    }
144
-}
145
-
146
-=item is_valid_file($path[, $name]);
147
-
148
-B<Description:> is_valid_file works the same way as is_valid_markup, except that
149
-you can specify the text to validate with the path to a filename. This is useful
150
-if you have pregenerated all your HTML files locally, and now wish to test them.
151
-
152
-B<Parameters:> $path, a scalar, $name, an optional descriptive test name.
153
-
154
-B<Returns:> None.
155
-
156
-=cut
157
-
158
-sub is_valid_file {
159
-    my ($file, $message) = @_;
160
-    _check_plan() if $not_checked;
161
-    if ($v->validate_file($file)) {
162
-        _result($v, $message);
163
-    } else {
164
-        _validator_err($v, "file");
165
-    }
166
-}
167
-
168
-
169
-=item is_valid($url[, $name]);
170
-
171
-B<Description:> is_valid, again, works very similarly to the is_valid_file and
172
-is_valid_file, except you specify a document that is already online with its
173
-URL. This can be useful if you wish to periodically test a website or webpage
174
-that dynamically changes over time for example, like a blog or a wiki, without
175
-first saving the html to a file using your browswer, or a utility such as wget.
176
-
177
-B<Parameters:> $url, a scalar, $name, an optional descriptive test name.
178
-
179
-B<Returns:> None.
180
-
181
-=cut
182
-
183
-sub is_valid {
184
-    my ($uri, $message) = @_;
185
-    _check_plan() if $not_checked;
186
-    if ($v->validate($uri)) {
187
-       _result($v, $message);
188
-    } else {
189
-        _validator_err($v, "URI");
190
-    }
191
-}
192
-
193
-sub _validator_err {
194
-    my ($validator, $type) = @_;
195
-    __PACKAGE__->builder->ok(0, "Failed to validate $type.");
196
-    __PACKAGE__->builder->diag($v->validator_error());
197
-}
198
-
199
-sub _result {
200
-    my ($validator, $message) = @_;
201
-    if ($validator->is_valid()) {
202
-        __PACKAGE__->builder->ok(1, $message);
203
-    } else {
204
-        my $num = $validator->num_errors();
205
-        my $plurality = ($num == 1) ? "error" : "errors";
206
-        __PACKAGE__->builder->ok(0, $message . " ($num $plurality).");
207
-    }
208
-}
209
-
210
-
211
-=item diag_html($url);
212
-
213
-B<Description:> If you want to display the actual errors reported by
214
-the service for a particular test, you can use the diag_html function.
215
-Please note that you must have imported 'show_detail' for this to
216
-work properly.
217
-
218
-  use Test::HTML::W3C 'show_detail';
219
-
220
-  is_valid_markup("<html></html">, "My simple test") or diag_html();
221
-
222
-B<Parameters:> $url, a scalar.
223
-
224
-B<Returns:> None.
225
-
226
-=cut
227
-
228
-sub diag_html {
229
-    my $tb = __PACKAGE__->builder();
230
-    if ($show_detail) {
231
-        my @errs = $v->errors();
232
-        my $e;
233
-        foreach my $error ( @{$v->errors()} ) {
234
-             $e .= sprintf("%s at line %d\n", $error->msg, $error->line);
235
-        }
236
-        $tb->diag($e);
237
-    } else {
238
-        $tb->diag("You need to import 'show_detail' in order to call diag_html\n");
239
-    }
240
-}
241
-
242
-
243
-1;
244
-
245
-__END__
246
-
247
-=back
248
-
249
-=head1 SEE ALSO
250
-
251
-L<Test::Builder::Module> for creating your own testing modules.
252
-
253
-L<Test::More> for another popular testing framework, also based on
254
-Test::Builder
255
-
256
-L<Test::Harness> for detils about how test results are interpreted.
257
-
258
-=head1 AUTHORS
259
-
260
-Victor E<lt>victor73@gmail.comE<gt> with inspiration
261
-from the authors of the Test::More and WebService::Validator::W3C:HTML
262
-modules.
263
-
264
-=head1 BUGS
265
-
266
-See F<http://rt.cpan.org> to report and view bugs.
267
-
268
-=head1 COPYRIGHT
269
-
270
-Copyright 2006 by Victor E<lt>victor73@gmail.comE<gt>.
271
-
272
-This program is free software; you can redistribute it and/or
273
-modify it under the same terms as Perl itself.
274
-
275
-See F<http://www.perl.com/perl/misc/Artistic.html>

+ 0
- 1547
wala/lib/Test/More.pm
File diff suppressed because it is too large
View File


+ 0
- 230
wala/lib/Test/Simple.pm View File

@@ -1,230 +0,0 @@
1
-package Test::Simple;
2
-
3
-use 5.004;
4
-
5
-use strict 'vars';
6
-use vars qw($VERSION @ISA @EXPORT);
7
-$VERSION = '0.70';
8
-$VERSION = eval $VERSION;    # make the alpha version come out as a number
9
-
10
-use Test::Builder::Module;
11
-@ISA    = qw(Test::Builder::Module);
12
-@EXPORT = qw(ok);
13
-
14
-my $CLASS = __PACKAGE__;
15
-
16
-
17
-=head1 NAME
18
-
19
-Test::Simple - Basic utilities for writing tests.
20
-
21
-=head1 SYNOPSIS
22
-
23
-  use Test::Simple tests => 1;
24
-
25
-  ok( $foo eq $bar, 'foo is bar' );
26
-
27
-
28
-=head1 DESCRIPTION
29
-
30
-** If you are unfamiliar with testing B<read Test::Tutorial> first! **
31
-
32
-This is an extremely simple, extremely basic module for writing tests
33
-suitable for CPAN modules and other pursuits.  If you wish to do more
34
-complicated testing, use the Test::More module (a drop-in replacement
35
-for this one).
36
-
37
-The basic unit of Perl testing is the ok.  For each thing you want to
38
-test your program will print out an "ok" or "not ok" to indicate pass
39
-or fail.  You do this with the ok() function (see below).
40
-
41
-The only other constraint is you must pre-declare how many tests you
42
-plan to run.  This is in case something goes horribly wrong during the
43
-test and your test program aborts, or skips a test or whatever.  You
44
-do this like so:
45
-
46
-    use Test::Simple tests => 23;
47
-
48
-You must have a plan.
49
-
50
-
51
-=over 4
52
-
53
-=item B<ok>
54
-
55
-  ok( $foo eq $bar, $name );
56
-  ok( $foo eq $bar );
57
-
58
-ok() is given an expression (in this case C<$foo eq $bar>).  If it's
59
-true, the test passed.  If it's false, it didn't.  That's about it.
60
-
61
-ok() prints out either "ok" or "not ok" along with a test number (it
62
-keeps track of that for you).
63
-
64
-  # This produces "ok 1 - Hell not yet frozen over" (or not ok)
65
-  ok( get_temperature($hell) > 0, 'Hell not yet frozen over' );
66
-
67
-If you provide a $name, that will be printed along with the "ok/not
68
-ok" to make it easier to find your test when if fails (just search for
69
-the name).  It also makes it easier for the next guy to understand
70
-what your test is for.  It's highly recommended you use test names.
71
-
72
-All tests are run in scalar context.  So this:
73
-
74
-    ok( @stuff, 'I have some stuff' );
75
-
76
-will do what you mean (fail if stuff is empty)
77
-
78
-=cut
79
-
80
-sub ok ($;$) {
81
-    $CLASS->builder->ok(@_);
82
-}
83
-
84
-
85
-=back
86
-
87
-Test::Simple will start by printing number of tests run in the form
88
-"1..M" (so "1..5" means you're going to run 5 tests).  This strange
89
-format lets Test::Harness know how many tests you plan on running in
90
-case something goes horribly wrong.
91
-
92
-If all your tests passed, Test::Simple will exit with zero (which is
93
-normal).  If anything failed it will exit with how many failed.  If
94
-you run less (or more) tests than you planned, the missing (or extras)
95
-will be considered failures.  If no tests were ever run Test::Simple
96
-will throw a warning and exit with 255.  If the test died, even after
97
-having successfully completed all its tests, it will still be
98
-considered a failure and will exit with 255.
99
-
100
-So the exit codes are...
101
-
102
-    0                   all tests successful
103
-    255                 test died or all passed but wrong # of tests run
104
-    any other number    how many failed (including missing or extras)
105
-
106
-If you fail more than 254 tests, it will be reported as 254.
107
-
108
-This module is by no means trying to be a complete testing system.
109
-It's just to get you started.  Once you're off the ground its
110
-recommended you look at L<Test::More>.
111
-
112
-
113
-=head1 EXAMPLE
114
-
115
-Here's an example of a simple .t file for the fictional Film module.
116
-
117
-    use Test::Simple tests => 5;
118
-
119
-    use Film;  # What you're testing.
120
-
121
-    my $btaste = Film->new({ Title    => 'Bad Taste',
122
-                             Director => 'Peter Jackson',
123
-                             Rating   => 'R',
124
-                             NumExplodingSheep => 1
125
-                           });
126
-    ok( defined($btaste) && ref $btaste eq 'Film,     'new() works' );
127
-
128
-    ok( $btaste->Title      eq 'Bad Taste',     'Title() get'    );
129
-    ok( $btaste->Director   eq 'Peter Jackson', 'Director() get' );
130
-    ok( $btaste->Rating     eq 'R',             'Rating() get'   );
131
-    ok( $btaste->NumExplodingSheep == 1,        'NumExplodingSheep() get' );
132
-
133
-It will produce output like this:
134
-
135
-    1..5
136
-    ok 1 - new() works
137
-    ok 2 - Title() get
138
-    ok 3 - Director() get
139
-    not ok 4 - Rating() get
140
-    #   Failed test 'Rating() get'
141
-    #   in t/film.t at line 14.
142
-    ok 5 - NumExplodingSheep() get
143
-    # Looks like you failed 1 tests of 5
144
-
145
-Indicating the Film::Rating() method is broken.
146
-
147
-
148
-=head1 CAVEATS
149
-
150
-Test::Simple will only report a maximum of 254 failures in its exit
151
-code.  If this is a problem, you probably have a huge test script.
152
-Split it into multiple files.  (Otherwise blame the Unix folks for
153
-using an unsigned short integer as the exit status).
154
-
155
-Because VMS's exit codes are much, much different than the rest of the
156
-universe, and perl does horrible mangling to them that gets in my way,
157
-it works like this on VMS.
158
-
159
-    0     SS$_NORMAL        all tests successful
160
-    4     SS$_ABORT         something went wrong
161
-
162
-Unfortunately, I can't differentiate any further.
163
-
164
-
165
-=head1 NOTES
166
-
167
-Test::Simple is B<explicitly> tested all the way back to perl 5.004.
168
-
169
-Test::Simple is thread-safe in perl 5.8.0 and up.
170
-
171
-=head1 HISTORY
172
-
173
-This module was conceived while talking with Tony Bowden in his
174
-kitchen one night about the problems I was having writing some really
175
-complicated feature into the new Testing module.  He observed that the
176
-main problem is not dealing with these edge cases but that people hate
177
-to write tests B<at all>.  What was needed was a dead simple module
178
-that took all the hard work out of testing and was really, really easy
179
-to learn.  Paul Johnson simultaneously had this idea (unfortunately,
180
-he wasn't in Tony's kitchen).  This is it.
181
-
182
-
183
-=head1 SEE ALSO
184
-
185
-=over 4
186
-
187
-=item L<Test::More>
188
-
189
-More testing functions!  Once you outgrow Test::Simple, look at
190
-Test::More.  Test::Simple is 100% forward compatible with Test::More
191
-(i.e. you can just use Test::More instead of Test::Simple in your
192
-programs and things will still work).
193
-
194
-=item L<Test>
195
-
196
-The original Perl testing module.
197
-
198
-=item L<Test::Unit>
199
-
200
-Elaborate unit testing.
201
-
202
-=item L<Test::Inline>, L<SelfTest>
203
-
204
-Embed tests in your code!
205
-
206
-=item L<Test::Harness>
207
-
208
-Interprets the output of your test program.
209
-
210
-=back
211
-
212
-
213
-=head1 AUTHORS
214
-
215
-Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
216
-E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
217
-
218
-
219
-=head1 COPYRIGHT
220
-
221
-Copyright 2001, 2002, 2004 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
222
-
223
-This program is free software; you can redistribute it and/or 
224
-modify it under the same terms as Perl itself.
225
-
226
-See F<http://www.perl.com/perl/misc/Artistic.html>
227
-
228
-=cut
229
-
230
-1;

+ 0
- 603
wala/lib/Test/Tutorial.pod View File

@@ -1,603 +0,0 @@
1
-=head1 NAME
2
-
3
-Test::Tutorial - A tutorial about writing really basic tests
4
-
5
-=head1 DESCRIPTION
6
-
7
-
8
-I<AHHHHHHH!!!!  NOT TESTING!  Anything but testing!  
9
-Beat me, whip me, send me to Detroit, but don't make 
10
-me write tests!>
11
-
12
-I<*sob*>
13
-
14
-I<Besides, I don't know how to write the damned things.>
15
-
16
-
17
-Is this you?  Is writing tests right up there with writing
18
-documentation and having your fingernails pulled out?  Did you open up
19
-a test and read 
20
-
21
-    ######## We start with some black magic
22
-
23
-and decide that's quite enough for you?
24
-
25
-It's ok.  That's all gone now.  We've done all the black magic for
26
-you.  And here are the tricks...
27
-
28
-
29
-=head2 Nuts and bolts of testing.
30
-
31
-Here's the most basic test program.
32
-
33
-    #!/usr/bin/perl -w
34
-
35
-    print "1..1\n";
36
-
37
-    print 1 + 1 == 2 ? "ok 1\n" : "not ok 1\n";
38
-
39
-since 1 + 1 is 2, it prints:
40
-
41
-    1..1
42
-    ok 1
43
-
44
-What this says is: C<1..1> "I'm going to run one test." [1] C<ok 1>
45
-"The first test passed".  And that's about all magic there is to
46
-testing.  Your basic unit of testing is the I<ok>.  For each thing you
47
-test, an C<ok> is printed.  Simple.  B<Test::Harness> interprets your test
48
-results to determine if you succeeded or failed (more on that later).
49
-
50
-Writing all these print statements rapidly gets tedious.  Fortunately,
51
-there's B<Test::Simple>.  It has one function, C<ok()>.
52
-
53
-    #!/usr/bin/perl -w
54
-
55
-    use Test::Simple tests => 1;
56
-
57
-    ok( 1 + 1 == 2 );
58
-
59
-and that does the same thing as the code above.  C<ok()> is the backbone
60
-of Perl testing, and we'll be using it instead of roll-your-own from
61
-here on.  If C<ok()> gets a true value, the test passes.  False, it
62
-fails.
63
-
64
-    #!/usr/bin/perl -w
65
-
66
-    use Test::Simple tests => 2;
67
-    ok( 1 + 1 == 2 );
68
-    ok( 2 + 2 == 5 );
69
-
70
-from that comes
71
-
72
-    1..2
73
-    ok 1
74
-    not ok 2
75
-    #     Failed test (test.pl at line 5)
76
-    # Looks like you failed 1 tests of 2.
77
-
78
-C<1..2> "I'm going to run two tests."  This number is used to ensure
79
-your test program ran all the way through and didn't die or skip some
80
-tests.  C<ok 1> "The first test passed."  C<not ok 2> "The second test
81
-failed".  Test::Simple helpfully prints out some extra commentary about
82
-your tests.
83
-
84
-It's not scary.  Come, hold my hand.  We're going to give an example
85
-of testing a module.  For our example, we'll be testing a date
86
-library, B<Date::ICal>.  It's on CPAN, so download a copy and follow
87
-along. [2]
88
-
89
-
90
-=head2 Where to start?
91
-
92
-This is the hardest part of testing, where do you start?  People often
93
-get overwhelmed at the apparent enormity of the task of testing a
94
-whole module.  Best place to start is at the beginning.  Date::ICal is
95
-an object-oriented module, and that means you start by making an
96
-object.  So we test C<new()>.
97
-
98
-    #!/usr/bin/perl -w
99
-
100
-    use Test::Simple tests => 2;
101
-
102
-    use Date::ICal;
103
-
104
-    my $ical = Date::ICal->new;         # create an object
105
-    ok( defined $ical );                # check that we got something
106
-    ok( $ical->isa('Date::ICal') );     # and it's the right class
107
-
108
-run that and you should get:
109
-
110
-    1..2
111
-    ok 1
112
-    ok 2
113
-
114
-congratulations, you've written your first useful test.
115
-
116
-
117
-=head2 Names
118
-
119
-That output isn't terribly descriptive, is it?  When you have two
120
-tests you can figure out which one is #2, but what if you have 102?
121
-
122
-Each test can be given a little descriptive name as the second
123
-argument to C<ok()>.
124
-
125
-    use Test::Simple tests => 2;
126
-
127
-    ok( defined $ical,              'new() returned something' );
128
-    ok( $ical->isa('Date::ICal'),   "  and it's the right class" );
129
-
130
-So now you'd see...
131
-
132
-    1..2
133
-    ok 1 - new() returned something
134
-    ok 2 -   and it's the right class
135
-
136
-
137
-=head2 Test the manual
138
-
139
-Simplest way to build up a decent testing suite is to just test what
140
-the manual says it does. [3] Let's pull something out of the 
141
-L<Date::ICal/SYNOPSIS> and test that all its bits work.
142
-
143
-    #!/usr/bin/perl -w
144
-
145
-    use Test::Simple tests => 8;
146
-
147
-    use Date::ICal;
148
-
149
-    $ical = Date::ICal->new( year => 1964, month => 10, day => 16, 
150
-                             hour => 16, min => 12, sec => 47, 
151
-                             tz => '0530' );
152
-
153
-    ok( defined $ical,            'new() returned something' );
154
-    ok( $ical->isa('Date::ICal'), "  and it's the right class" );
155
-    ok( $ical->sec   == 47,       '  sec()'   );
156
-    ok( $ical->min   == 12,       '  min()'   );    
157
-    ok( $ical->hour  == 16,       '  hour()'  );
158
-    ok( $ical->day   == 17,       '  day()'   );
159
-    ok( $ical->month == 10,       '  month()' );
160
-    ok( $ical->year  == 1964,     '  year()'  );
161
-
162
-run that and you get:
163
-
164
-    1..8
165
-    ok 1 - new() returned something
166
-    ok 2 -   and it's the right class
167
-    ok 3 -   sec()
168
-    ok 4 -   min()
169
-    ok 5 -   hour()
170
-    not ok 6 -   day()
171
-    #     Failed test (- at line 16)
172
-    ok 7 -   month()
173
-    ok 8 -   year()
174
-    # Looks like you failed 1 tests of 8.
175
-
176
-Whoops, a failure! [4] Test::Simple helpfully lets us know on what line
177
-the failure occurred, but not much else.  We were supposed to get 17,
178
-but we didn't.  What did we get??  Dunno.  We'll have to re-run the
179
-test in the debugger or throw in some print statements to find out.
180
-
181
-Instead, we'll switch from B<Test::Simple> to B<Test::More>.  B<Test::More>
182
-does everything B<Test::Simple> does, and more!  In fact, Test::More does
183
-things I<exactly> the way Test::Simple does.  You can literally swap
184
-Test::Simple out and put Test::More in its place.  That's just what
185
-we're going to do.
186
-
187
-Test::More does more than Test::Simple.  The most important difference
188
-at this point is it provides more informative ways to say "ok".
189
-Although you can write almost any test with a generic C<ok()>, it
190
-can't tell you what went wrong.  Instead, we'll use the C<is()>
191
-function, which lets us declare that something is supposed to be the
192
-same as something else:
193
-
194
-    #!/usr/bin/perl -w
195
-
196
-    use Test::More tests => 8;
197
-
198
-    use Date::ICal;
199
-
200
-    $ical = Date::ICal->new( year => 1964, month => 10, day => 16, 
201
-                             hour => 16, min => 12, sec => 47, 
202
-                             tz => '0530' );
203
-
204
-    ok( defined $ical,            'new() returned something' );
205
-    ok( $ical->isa('Date::ICal'), "  and it's the right class" );
206
-    is( $ical->sec,     47,       '  sec()'   );
207
-    is( $ical->min,     12,       '  min()'   );    
208
-    is( $ical->hour,    16,       '  hour()'  );
209
-    is( $ical->day,     17,       '  day()'   );
210
-    is( $ical->month,   10,       '  month()' );
211
-    is( $ical->year,    1964,     '  year()'  );
212
-
213
-"Is C<$ical-E<gt>sec> 47?"  "Is C<$ical-E<gt>min> 12?"  With C<is()> in place,
214
-you get some more information
215
-
216
-    1..8
217
-    ok 1 - new() returned something
218
-    ok 2 -   and it's the right class
219
-    ok 3 -   sec()
220
-    ok 4 -   min()
221
-    ok 5 -   hour()
222
-    not ok 6 -   day()
223
-    #     Failed test (- at line 16)
224
-    #          got: '16'
225
-    #     expected: '17'
226
-    ok 7 -   month()
227
-    ok 8 -   year()
228
-    # Looks like you failed 1 tests of 8.
229
-
230
-letting us know that C<$ical-E<gt>day> returned 16, but we expected 17.  A
231
-quick check shows that the code is working fine, we made a mistake
232
-when writing up the tests.  Just change it to:
233
-
234
-    is( $ical->day,     16,       '  day()'   );
235
-
236
-and everything works.
237
-
238
-So any time you're doing a "this equals that" sort of test, use C<is()>.
239
-It even works on arrays.  The test is always in scalar context, so you
240
-can test how many elements are in a list this way. [5]
241
-
242
-    is( @foo, 5, 'foo has 5 elements' );
243
-
244
-
245
-=head2 Sometimes the tests are wrong
246
-
247
-Which brings us to a very important lesson.  Code has bugs.  Tests are
248
-code.  Ergo, tests have bugs.  A failing test could mean a bug in the
249
-code, but don't discount the possibility that the test is wrong.
250
-
251
-On the flip side, don't be tempted to prematurely declare a test
252
-incorrect just because you're having trouble finding the bug.
253
-Invalidating a test isn't something to be taken lightly, and don't use
254
-it as a cop out to avoid work.
255
-
256
-
257
-=head2 Testing lots of values
258
-
259
-We're going to be wanting to test a lot of dates here, trying to trick
260
-the code with lots of different edge cases.  Does it work before 1970?
261
-After 2038?  Before 1904?  Do years after 10,000 give it trouble?
262
-Does it get leap years right?  We could keep repeating the code above,
263
-or we could set up a little try/expect loop.
264
-
265
-    use Test::More tests => 32;
266
-    use Date::ICal;
267
-
268
-    my %ICal_Dates = (
269
-            # An ICal string     And the year, month, date
270
-            #                    hour, minute and second we expect.
271
-            '19971024T120000' =>    # from the docs.
272
-                                [ 1997, 10, 24, 12,  0,  0 ],
273
-            '20390123T232832' =>    # after the Unix epoch
274
-                                [ 2039,  1, 23, 23, 28, 32 ],
275
-            '19671225T000000' =>    # before the Unix epoch
276
-                                [ 1967, 12, 25,  0,  0,  0 ],
277
-            '18990505T232323' =>    # before the MacOS epoch
278
-                                [ 1899,  5,  5, 23, 23, 23 ],
279
-    );
280
-
281
-
282
-    while( my($ical_str, $expect) = each %ICal_Dates ) {
283
-        my $ical = Date::ICal->new( ical => $ical_str );
284
-
285
-        ok( defined $ical,            "new(ical => '$ical_str')" );
286
-        ok( $ical->isa('Date::ICal'), "  and it's the right class" );
287
-
288
-        is( $ical->year,    $expect->[0],     '  year()'  );
289
-        is( $ical->month,   $expect->[1],     '  month()' );
290
-        is( $ical->day,     $expect->[2],     '  day()'   );
291
-        is( $ical->hour,    $expect->[3],     '  hour()'  );
292
-        is( $ical->min,     $expect->[4],     '  min()'   );    
293
-        is( $ical->sec,     $expect->[5],     '  sec()'   );
294
-    }
295
-
296
-So now we can test bunches of dates by just adding them to
297
-C<%ICal_Dates>.  Now that it's less work to test with more dates, you'll
298
-be inclined to just throw more in as you think of them.
299
-Only problem is, every time we add to that we have to keep adjusting
300
-the C<use Test::More tests =E<gt> ##> line.  That can rapidly get
301
-annoying.  There's two ways to make this work better.
302
-
303
-First, we can calculate the plan dynamically using the C<plan()>
304
-function.
305
-
306
-    use Test::More;
307
-    use Date::ICal;
308
-
309
-    my %ICal_Dates = (
310
-        ...same as before...
311
-    );
312
-
313
-    # For each key in the hash we're running 8 tests.
314
-    plan tests => keys %ICal_Dates * 8;
315 <