File Coverage

lib/WWW/Selenium/Utils.pm

Criterion	Covered	Total	%
statement	212	215	98.6
branch	92	126	73.0
condition	26	35	74.2
subroutine	22	22	100.0
pod	1	10	10.0
total	353	408	86.5

package WWW::Selenium::Utils;

use 5.006;
use strict;
use warnings;
use Carp;
use File::Find;
use Config;
use WWW::Selenium::Utils::Actions qw(%selenium_actions);

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(generate_suite cat parse_wikifile);

our $VERSION = '0.09';

sub html_header;
sub html_footer;

sub generate_suite {
    my %opts = @_;

    my %config = parse_config();
    $opts{$_} ||= $config{$_} for keys %config;

    croak "Must provide a directory of tests!\n" unless $opts{test_dir};

    _generate_suite( %opts );

    # create a test Suite index
    create_suite_index($opts{test_dir}, $opts{index}) if $opts{index};
}

sub _generate_suite {
    my %opts = @_;
    my $testdir = $opts{test_dir};
    $testdir =~ s#/$##;
    croak "$testdir is not a directory!\n" unless -d $testdir;
    my $files = $opts{files} || test_files($testdir, $opts{perdir}, \%opts);

    my $suite = "$testdir/TestSuite.html";
    my $date = localtime;

    open(my $fh, ">$suite.tmp") or croak "Can't open $suite.tmp: $!";
    print $fh html_header(title => "Test Suite",
                          text  => "Generated at $date",
                         );

    my $tests_added = 0;
    for (sort {$a cmp $b} @$files) {
        next if /(?:\.tmp|TestSuite\.html)$/;

        my $f = $_;
        my $fp = "$testdir/$f";
        if ($f =~ /(.+)\.html$/) {
            my $basename = $1;
            # skip html files that we have or will generate
            next if -e "$testdir/$basename.wiki";
            # find orphaned html files
            my $html = cat($fp);
            if ($html =~ m#Auto-generated from $testdir/$basename\.wiki# and
                        !-e "$testdir/$basename.wiki") {
                print "Deleting orphaned file $fp\n" if $opts{verbose};
                unlink $fp or croak "Can't unlink $fp: $!";
                next;
            }
        }

        print "Adding row for $f\n" if $opts{verbose};
        if (/\.wiki$/) {
            $f = wiki2html($fp,
                           verbose => $opts{verbose},
                           base_href => $opts{base_href});
            $f =~ s/^$testdir\///;
            $fp = "$testdir/$f";
        }
        my $title = find_title($fp);
        print $fh qq(\t
        $tests_added++;
    }
    #print the footer
    print $fh html_footer();
    close $fh or croak "Can't close $suite.tmp: $!";

    if ($tests_added) {
        # rename into place
        rename "$suite.tmp", $suite or croak "can't rename $suite.tmp $suite: $!";
        print "Created new $suite\n" if $opts{verbose};
    }
    else {
        unlink "$suite.tmp";
    }
}

sub test_files {
    my ($testdir, $perdir, $opts) = @_;

    my @tests;
    if ($perdir) {
        my @files = glob("$testdir/*");
        foreach my $f (@files) {
            if (-d $f) {
                $opts->{test_dir} = $f;
                generate_suite( %$opts );
                next;
            }
            push @tests, $f;
        }
    }
    else {
        find(sub { push @tests, $File::Find::name }, $testdir);
    }

    @tests = grep { !-d $_ and m#(?:wiki|html)$# } @tests;
    for (@tests) {
        s#^$testdir/?##;
        s#^.+/tests/##;
    }

    return \@tests;
}

sub wiki2html {
    my ($wiki, %opts) = @_;
    my $verbose = $opts{verbose};
    my $base_href = $opts{base_href};
    $base_href =~ s#/$## if $base_href;

    (my $html = $wiki) =~ s#\.wiki$#.html#;

    my $results = parse_wikifile(filename => $wiki,
                                 base_href => $base_href);
    if ($results->{errors}) {
        croak "Error parsing file $wiki:\n  "
              . join("\n  ", @{$results->{errors}})
              . "\n";
    }

    print "Generating html for ($results->{title}): $html\n" if $verbose;
    open(my $out, ">$html") or croak "Can't open $html: $!";
    print $out html_header( title => $results->{title},
                    text => "Auto-generated from $wiki");
    foreach my $r (@{$results->{rows}}) {
        print $out "\n\t
                   join('', map "
                   "
    }

    my $now = localtime;
    print $out html_footer("Auto-generated from $wiki at $now\n");
    close $out or croak "Can't write $html: $!";
    return $html;
}

sub parse_wikifile {
    my %opts = @_;
    my $filename = $opts{filename};
    my $base_href = $opts{base_href};
    my $include   = $opts{include};
    (my $base_dir = $filename) =~ s#(.+)/.+$#$1#;

    my $title;
    my @rows;
    my @errors;

    # $. and $_ are global, so we don't need to pass them in
    # to this closure
    my $parse_error = sub {
        push @errors, "line $.: $_[0] ($_)";
    };

    open(my $in, $filename) or croak "Can't open $filename: $!";
    while(<$in>) {
        s/^\s*//;
        next if /^#/ or /^\s*$/;
        chomp;

        # included files won't have a title
        if (not defined $title and not $include) {
            $title = $_;
            $title =~ s#^\s*##;
            $title =~ s#^\|(.+)\|$#$1#;
            next;
        }
        elsif (/^\s*                   # some possible leading space
                \|\s*([^\|]+?)\s*\|    # cmd
                (?:\s*([^\|]+?)\s*\|)? # opt1 (optional)
                (?:\s*([^\|]+?)\s*\|)? # opt2 (optional)
                \s*$/x) {
            my ($cmd, $opt1, $opt2) = ($1,$2,$3);
            $parse_error->("No command found") and next unless $cmd;

            my $numargs = (grep { defined $_ } ($opt1, $opt2));
            my $expected_args = $selenium_actions{lc($cmd)};
            if (defined $expected_args and $expected_args != $numargs) {
                $parse_error->("Incorrect number of arguments for $cmd");
                next;
            }

            $opt1 = ' ' unless defined $opt1;
            $opt2 = ' ' unless defined $opt2;
            if ($base_href and ($cmd eq "open" or
                                $cmd =~ /(?:assert|verify)Location/)) {
                $opt1 =~ s#^/##;
                $opt1 = "$base_href/$opt1";
            }
            push @rows, [ $cmd, $opt1, $opt2 ];
        }
        elsif (/^\s*include\s+(.+)\s*$/) {
            my $incl = $1;
            $incl = "$base_dir/$1" unless -e $1;
            unless (-e $incl) {
                $parse_error->("Can't include $incl - file doesn't exist!");
                next;
            }
            my $r = parse_wikifile( %opts, filename => $incl,
                                          include => 1);
            push @rows,   @{$r->{rows}}   if $r->{rows};
            push @errors, @{$r->{errors}} if $r->{errors};
        }
        else {
            $parse_error->("Invalid line");
        }
    }
    close $in or croak "Can't close $filename: $!";
    return { $title ? (title => $title) : (),
             @errors ? (errors => \@errors) : (),
             rows  => \@rows,
           };
}

sub find_title {
    my $filename = shift;

    open(my $fh, $filename) or croak "Can't open $filename: $!";
    my $contents;
    {
        local $/;
        $contents = <$fh>;
    }
    close $fh or croak "Can't close $filename: $!";

    return $filename unless $contents;
    return $1 if $contents =~ m#\s*(.+)\s*#;
    return $1 if $filename =~ m#^.+/(.+)\.html$#;
    return $filename;
}

sub create_suite_index {
    my ($testdir, $index) = @_;
    my @suites;
    find( sub { push @suites, $File::Find::name if /TestSuite\.html$/ }, $testdir);
    return unless @suites;

    (my $index_dir = $index) =~ s#^(.+)/.+$#$1#;
    open(my $fh, ">$index.tmp") or croak "Can't open $index.tmp: $!";
    print $fh html_header(title => "Selenium TestSuites");
    foreach my $s (@suites) {
        my $name = "Main";
        $name = $1 if $s =~ m#\Q$testdir\E/(.+)/TestSuite\.html$#;
        (my $link = $s) =~ s#\Q$index_dir\E/##;
        print $fh qq(\t
    }
    print $fh html_footer;
    close $fh or croak "Can't write $index.tmp: $!";
    rename "$index.tmp", $index or croak "Can't rename $index.tmp to $index: $!";
}

sub html_header {
    my %opts = @_;
    my $title = $opts{title} || 'Generic Title';
    my $text = $opts{text} || '';

    my $header = <



          http-equiv="content-type">
    $title


    $text
     




284




 





 





 





 





 





 



        




285




 





 





 





 





 





 



          




286




 





 





 





 





 





 



           $title 




287




 





 





 





 





 





 



          




288




 





 





 





 





 





 



 EOT 




289




41





 





 





 





 





224



     return $header; 




290




 





 





 





 





 





 



 } 




291




 





 





 





 





 





 



   




292




 





 





 





 





 





 



 sub html_footer { 




293




33





 




  
100
  



  
33
  



  
0
  




101



     my $text = shift || ''; 




294




33





 





 





 





 





81



     return <




295




 





 





 





 





 





 



        




296




EOT
    return $header;
}

sub html_footer {
    my $text = shift || '';
    return <


    $text


EOT
}

sub cat {
    my $file = shift;
    my $contents;
    eval {
        open(my $fh, $file) or croak "Can't open $file: $!";
        {
            local $/;
            $contents = <$fh>;
        }
        close $fh or croak "Can't close $file: $!";
    };
    warn if $@;
    return $contents;
}

sub parse_config {
    my $file = ($ENV{SELUTILS_ROOT} || $Config{prefix}) . "/etc/selutils.conf";
    return () unless -e $file;
    # try evaling the file (current file format)
    open(my $fh, $file) or croak "Can't open $file: $!";
    my $contents;
    {
        local $/ = undef;
        $contents = <$fh>;
    }
    close $fh or die "Can't close $file: $!";

    our $perdir;
    our $test_dir;
    our $index;
    {
        local $SIG{__WARN__} = sub {}; # hide eval errors
        eval $contents;
    }
    my $eval_err = $@;

    # failed to eval file - try reading as an old style config
    if ($eval_err) {
        while($contents =~ /^\s*(\w+)\s*=\s*['"]?([^'"]+)['"]?\s*$/mg) {
            $perdir = $2 if $1 eq 'perdir';
            $index = $2 if $1 eq 'index';
            $test_dir = $2 if $1 eq 'test_dir';
        }
        warn "$file eval error: $eval_err\n" unless $test_dir;
    }
    my %config = ( perdir => $perdir,
                   test_dir => $test_dir,
                   index => $index,
                 );
    return %config;
}

1;
__END__