Data-Table-Text
view release on metacpan or search on metacpan
lib/Data/Table/Text.pm view on Meta::CPAN
unless(-d $source) # Check the folder exists
{confess "No such folder: $source";
}
return undef unless confirmHasCommandLineCommand(q(zip)); # Confirm we have zip
my $z = fpe(temporaryFile, q(zip)); # Local zip file
my $c = qq(cd $source; zip -qr $z .); # Zip command
xxx $c, qr(\A\s*\Z);
my $r = s3WriteFile($target, $z, %options); # Upload to S3
unlink $z;
$r
}
sub s3ZipFolders($%) # Zip local folders and upload them to S3 in parallel. B<$map> maps source folder names on the local machine to target folders on S3. B<%options> contains any additional...
{my ($map, %options) = @_; # Source folder to S3 mapping, S3 options
&runInParallel(&numberOfCpus(8), sub # Upload in parallel
{my ($r) = @_;
&s3ZipFolder(@$r, %options);
},
sub {},
map{[$_, $$map{$_}]} sort keys %$map);
}
#D1 GitHub # Simple interactions with L<GitHub> - for more complex interactions please use L<GitHub::Crud>.
sub downloadGitHubPublicRepo($$) # Get the contents of a public repo on GitHub and place them in a temporary folder whose name is returned to the caller or confess if no such repo exists.
{my ($user, $repo) = @_; # GitHub user, GitHub repo
my $t = temporaryFolder; # Folder to download to
my $z = fpe($t, qw(gh zip)); # Zip file
my $s = fpe(q(https://github.com/), $user, $repo, qw(archive master zip)); # L<url> to GitHub to retrieve zipped repository
confirmHasCommandLineCommand(q(wget)); # Conform we have wget
my $d = xxx qq(wget -O $z $s), qr(200 OK); # Run download
$d =~ m(ERROR 404: Not Found)s || !-e $z || fileSize($z) < 1e2 and # Make sure we got a zip file
confess "No such user/repo on GitHub or repo too small:\n$d\n";
xxx qq(cd $t; unzip $z; rm $z; ls -lah), qr(); # Unzip the zip file
$t # Return the folder containing the unzipped files
}
sub downloadGitHubPublicRepoFile($$$) # Get the contents of a B<$user> B<$repo> B<$file> from a public repo on GitHub and return them as a string.
{my ($user, $repo, $file) = @_; # GitHub user, GitHub repository, file name in repository
my $s = fpf(q(https://raw.githubusercontent.com/), $user, $repo, q(master), $file);
my $t = temporaryFile; # File to download into
my $d = xxx qq(wget -O $t $s), qr(200 OK); # Run download
$d =~ m(ERROR 404: Not Found)s and # Make sure we got the file
confess "No such user/repo/file on GitHub:\n$d\n";
-f $t or confess "No output from user/repo/file on GitHub"; # Check we got a result
my $r = readFile($t); # Read results
unlink $t; # Remove temporary output file
$r # Return data read from github
}
sub postProcessImagesForDocumentation(%) # Post process svg images into png and reload into repo for use by documentation. Useful for detailed svg images which can take a long time to load into a browser - it tr...
{my (%options) = @_; # Options
my $log = $options{log} // 1; # Show actions if true
my $size = $options{size} // 4096; # Longest size of png images to produce from svg
my $home = currentDirectory; # Home folder
my $dir = $options{target} // fpd qw(lib Silicon Chip); # Target folder for images
my $imgs = fpd $home, $dir; # Images source folder
$imgs = $home if $ENV{GITHUB_TOKEN}; # Change folders for github
my $svg = fpd $imgs, qw(svg); # Svg folder
my $png = fpd $imgs, qw(png); # Png folder
my ($user, $repo) = split m(/), $ENV{GITHUB_REPOSITORY}//''; # Userid and repo from github
makePath($png); # Make png folder
my @f = searchDirectoryTreesForMatchingFiles $svg, qw(.svg); # Svg files from which we make png files
my @r; # Results
for my $s(@f) # Svg files
{my $t = setFileExtension $s, q(png);
$t = swapFilePrefix $t, $svg, $png; # Matching png
my $x = readFile $s;
push @r, [$s]; # Record file being processed
if ($x =~ m(viewBox="0 0\s+(\d+)\s+(\d+)")) # Dimensions of image
{my ($x, $y) = ($1, $2);
my $m = maximum $x, $y; # Scale image to maximum requested size
$x *= int($size / $m);
$y *= int($size / $m);
say STDERR sprintf "Convert svg: x=%5d, y=%5d ".$s, $x, $y if $log; # Log change
my $c = qq(cairosvg -o $t --output-width $x --output-height $y $s); # Convert svg to png
my $r = qx($c);
push $r[-1]->@*, $r; # Save result
say STDERR $r if $r =~ m(\S);
}
}
for my $x(qw(gds png svg)) # Move images to target location
{my $s = fpd $imgs, $x;
next unless -e $s;
my $t = fpd $dir, $x;
copyFolder($s, $t);
clearFolder($s, undef);
}
@r # Results of each upload
}
#D1 Processes # Start processes, wait for them to terminate and retrieve their results
sub startProcess(&\%$) # Start new processes while the number of child processes recorded in B<%$pids> is less than the specified B<$maximum>. Use L<waitForAllStartedProcessesToFinish|/waitFor...
{my ($sub, $pids, $maximum) = @_; # Sub to start, hash in which to record the process ids, maximum number of processes to run at a time
warn "Deprecated in favor of newProcessStarter";
while(keys(%$pids) >= $maximum) # Wait for enough processes to terminate to bring us below the maximum number of processes allowed.
{my $p = waitpid 0,0;
# $$pids{$p} or confess "Pid $p not defined in ".dump($pids)."\n";
delete $$pids{$p}
}
if (my $pid = fork) # Create new process
{$$pids{$pid}++ # Update pids
}
else # Run sub in new process
{&$sub;
exit;
}
}
sub waitForAllStartedProcessesToFinish(\%) # Wait until all the processes started by L<startProcess|/startProcess> have finished.
{my ($pids) = @_; # Hash of started process ids
warn "Deprecated in favor of newProcessStarter";
while(keys %$pids) # Remaining processes
{my $p = waitpid 0,0;
# $$pids{$p} or cluck "Pid $p not defined in ".dump($pids)."\n";
lib/Data/Table/Text.pm view on Meta::CPAN
for my $l(keys @lines) # Tests associated with each method
{my $line = $lines[$l];
if (my @tags = $line =~ m/(?:\s#[T#]((?:\w|:)+))/g)
{my %tags; $tags{$_}++ for @tags;
for(grep {$tags{$_} > 1} sort keys %tags) # Check for duplicate example names on the same line
{warn "Duplicate example name $_ on line $l";
}
my @testLines = (extractTest($line)); # Text of tests to be used as examples concatenated together
if ($line =~ m/<<(END|'END'|"END")/) # Process here documents
{for(my $L = $l + 1; $L < @lines; ++$L)
{my $nextLine = $lines[$L];
push @testLines, extractTest($nextLine);
last if $nextLine =~ m/\AEND/; # Finish on END
}
}
if ($line =~ m(\A(\s*)if\s*\x28(\d+|github)\x29)i) # Process "if (\d+)" recording leading spaces
{my $S = $1; my $minimumNumberOfLines = 0;#$2; # Leading spaces so we can balance the indentation of the closing curly bracket. Start testing for the closing } after this many lines
my $M = $maxLinesInExample;
for(my ($L, $N) = ($l + 1, 0); $L < @lines; ++$L, ++$N)
{my $nextLine = $lines[$L];
push @testLines, extractTest($nextLine);
if ($N >= $minimumNumberOfLines and $nextLine =~ m/\A$S }/) # Finish on closing brace in column 2
{#say STDERR "End of example";
last;
}
else
{#say STDERR "$N ", $nextLine;
}
my $L = $l + 1;
$N < $M or fff($L, $perlModule, "Too many lines in example"); # Prevent overruns
}
if (@testLines > 1) # Remove leading and trailing 'if' if possible
{if ($testLines[0] =~ m(\A\s*if\s*\x{28}\d\x{29}\s*{)i)
{pop @testLines; shift @testLines;
}
}
}
if ($svg) # Look for svg image references being used as illustrations of examples
{my $png = $svg =~ s(svg/\Z) (png/)gsr; # Implied png folder
my @svg;
for my $l(@testLines) # Each line of the test
{if ($l =~ m(svg=>q\((.*?)\))) # Svg image found for this test
{my $s = $1; # Svg file name
my $p = sub {$l =~ m(pngs=>(\d+)) ? $1 : undef}->(); # Use png instead of svg
my $u = "$svg$s.svg"; # Implied svg file url
$u = "$png$s.png" if $p; # Implied png file url
push @svg, qq(\n\n=for html <img src="$u">) unless $svg{$u}++; # The new line takes the directive out of an example. Only include images otherwise the document gets very big very quickly
for my $i(1..99) # Test for svgs that already exist
{my $u = "$svg${s}_$i.svg"; # File name url
$u = "$png${s}_$i.png" if $p; # Implied png file url
my $f = "svg/${s}_$i.svg"; # Local svg file name
last unless -e $f; # Include file if it exists locally
push @svg, qq(\n\n=for html <img src="$u">) unless $svg{$u}++; # The new line takes the directive out of an example. Only include images otherwise the document gets very big very quickly
}
if (defined $p) # Png count
{for my $i(1..$p) # Add any additional svgs
{my $u = "$png${s}_$i.png"; # Png url
push @svg, qq(\n\n=for html <img src="$u">) unless $svg{$u}++; # The new line takes the directive out of an example. Only include images otherwise the document gets very big very quickly
}
}
}
}
push @testLines, @svg;
}
push @testLines, ''; # Blank line between each test line
for my $testLine(@testLines) # Save test lines
{for my $t(sort keys %tags)
{$testLine =~ s(!) (#)g if $t =~ m(\AupdateDocumentation\Z)s; # To prevent the example documentation using this method showing up for real.
push @{$examples{$t}}, $testLine;
}
}
push @{$moduleDescription{tests}}, [\@tags, \@testLines]; # Record tests in module description
}
}
for my $l(keys @lines) # Tests associated with replaceable methods
{my $M = $maxLinesInExample;
my $line = $lines[$l];
if ($line =~ m(\Asub\s+((\w|:)+).*#(\w*)[rR]))
{my $sub = $1;
my @testLines = ($line =~ s(\s#.*\Z) ()r);
for(my ($L, $N) = ($l + 1, 0); $L < @lines; ++$L, ++$N)
{my $nextLine = $lines[$L];
push @testLines, extractTest($nextLine);
last if $nextLine =~ m/\A }/; # Finish on closing brace in column 2
my $L = $l + 1;
$N < $M or fff($L, $perlModule, "Too many lines in test"); # Prevent overruns
}
push @testLines, ''; # Blank line between each test line
for my $testLine(@testLines) # Save test lines
{push @{$examples{$sub}}, $testLine;
}
}
}
for my $l(keys @lines) # Generated objects
{my $M = $maxLinesInExample;
my $line = $lines[$l];
if ($line =~ m(genHash\s*\x28\s*(q\x28.+\x29|__PACKAGE__).+?# (.+)\Z)) # GenHash
{my $p = $1; my $c = $2;
$p = $p =~ s(q[qw]?\x28|\x29) ()gsr =~ s(__PACKAGE__) ($package)gsr;
$genHashPackage{$p} = $c;
for(my ($L, $N) = ($l + 1, 0); $L < @lines; ++$L, ++$N)
{my $nextLine = $lines[$L];
if ($nextLine =~ m(\A\s+(\w+)\s*=>\s*.+?#(\w*)\s+(.*)\Z))
{my $flags = $genHashFlags{$p}{$1} = $2;
$genHashs {$p}{$1} = $3;
if (my $invalidFlags = $flags =~ s([I]) ()gsr)
{confess "Invalid flags $invalidFlags on line $L:\n$nextLine";
}
}
last if $nextLine =~ m/\A\s*\);/; # Finish on closing bracket
$N < $M or confess # Prevent overruns
( run in 1.638 second using v1.01-cache-2.11-cpan-39bf76dae61 )