Permalink
Browse files

Merge remote-tracking branch 'origin/ng-compat'

  • Loading branch information...
2 parents 302e4f8 + 4646a76 commit d1dd91779c8a8e37d5c7ca37bca9b93db3c8a28a @softmoth softmoth committed Jul 8, 2011
View
@@ -1,11 +1,13 @@
PERL6=perl6
-SOURCES=lib/November/CGI.pm lib/Text/Markup/Wiki/Minimal.pm \
+SOURCES=lib/November/URI/Grammar.pm lib/November/URI.pm \
+ lib/November/CGI.pm lib/Text/Markup/Wiki/Minimal.pm \
lib/Text/Markup/Wiki/MediaWiki.pm lib/Digest.pm \
- lib/November/Storage.pm lib/November/Storage/File.pm lib/November/Tags.pm \
- lib/November/URI.pm lib/November/URI/Grammar.pm lib/Dispatcher.pm \
- lib/Dispatcher/Rule.pm lib/November/Session.pm lib/November/Utils.pm \
- lib/November/Config.pm lib/Test/InputOutput.pm lib/Test/CGI.pm \
+ lib/November/Storage.pm lib/November/Utils.pm \
+ lib/November/Config.pm lib/November/Storage/File.pm lib/November/Tags.pm \
+ lib/Dispatcher/Rule.pm lib/Dispatcher.pm \
+ lib/November/Session.pm lib/November/Utils.pm \
+ lib/Test/InputOutput.pm lib/Test/CGI.pm \
lib/November/Cache.pm lib/November.pm
PIRS=$(SOURCES:.pm=.pir)
View
@@ -1,49 +1,13 @@
module Digest;
-# Known digests: md5, sha1, sha256, sha512, ripemd160
-sub digest(Str $text, Str $algo is copy = 'md5') is export {
- $algo = uc $algo;
- my $binary = Q:PIR {
- .local string text
- .local string algo
- .local pmc digest
-
- # Input
- $P0 = find_lex '$text'
- text = $P0
- $P0 = find_lex '$algo'
- algo = $P0
-
- # Choose the right digest.
- $P1 = loadlib 'digest_group'
- if algo == 'MD5' goto MD5
- if algo == 'SHA1' goto SHA1
- if algo == 'SHA256' goto SHA256
- if algo == 'SHA512' goto SHA512
- if algo == 'RIPEMD160' goto RIPEMD160
- MD5:
- digest = new 'MD5'
- goto COMPUTE
- SHA1:
- digest = new 'SHA1'
- goto COMPUTE
- SHA256:
- digest = new 'SHA256'
- goto COMPUTE
- SHA512:
- digest = new 'SHA512'
- goto COMPUTE
- RIPEMD160:
- digest = new 'RIPEMD160'
+use Digest::MD5;
+use Digest::SHA;
- COMPUTE:
- # Calculate the digest.
- digest.'Init'()
- digest.'Update'(text)
- $S0 = digest.'Final'()
-
- %r = box $S0
- };
- # Convert to hex.
- return [~] map { sprintf '%02x', .ord }, $binary.comb;
+# Known digests: md5, sha1, sha256, sha512, ripemd160
+sub digest(Str $text, Str $algo = 'md5') is export {
+ given $algo {
+ when 'md5' { return Digest::MD5.md5_hex($text) }
+ when 'sha256' { return Digest::SHA.sha256_hex($text) }
+ default { !!! "digest for $algo not yet implemented" }
+ }
}
View
@@ -0,0 +1,22 @@
+class Digest::SHA:auth<thou>:ver<0.01> {
+ pir::load_bytecode('Digest/sha256.pbc');
+
+ multi method sha256_hex (Str $str) {
+ my $sha256_hex = Q:PIR {
+ .local pmc f, g, str
+ str = find_lex '$str'
+ f = get_root_global ['parrot'; 'Digest'], '_sha256sum'
+ $P1 = f(str)
+ g = get_root_global ['parrot'; 'Digest'], '_sha256_hex'
+ $S0 = g($P1)
+ %r = box $S0
+ };
+
+ return $sha256_hex;
+ }
+
+ multi method sha256_hex (@strs) {
+ return self.sha256_hex(@strs.join(""));
+ }
+}
+
View
@@ -9,17 +9,21 @@ has Code $.code;
method match (@chunks) {
return False if @chunks != @!pattern;
- for @chunks Z @!pattern -> $chunk, Object $rule is copy {
+ # RAKUDO: Z seems to have a bug (fixed in nom), where [1,2] Z [*,*] yields (1, Any, 2, Any): the Whatever is lost
+ #for @chunks Z @!pattern -> $chunk, $rule is copy {
+ for ^@chunks -> $i {
+ my $chunk = @chunks[$i];
+ my $rule = @!pattern[$i];
+ #note "- chunk ({$chunk.perl}), rule ({$rule.perl})";
my $param;
if $rule ~~ Pair { ($param, $rule) = $rule.kv }
if ~$chunk ~~ $rule {
if $param {
- self."$param" = (~$/ || ~$chunk);
+ self."$param"() = ~($/ // $chunk);
} else {
- # RAKUDO: /./ ~~ Regex us false, but /./ ~~ Code is true
- @!args.push($/ || $chunk) if $rule ~~ Code | Whatever; # should by Regex | Whatever
+ @!args.push($/ || $chunk) if $rule ~~ Regex | Whatever;
}
}
else {
@@ -35,7 +39,7 @@ method apply {
#$!code(| @!args, controller => $.controller, action => $.action );
# workaround:
if $!controller and $!action {
- $!code(| @!args,action => $.action, controller => $.controller );
+ $!code(| @!args, action => $.action, controller => $.controller );
} elsif $!action {
$!code(| @!args, action => $.action );
} elsif $!controller {
View
@@ -1,5 +1,8 @@
use v6;
+# RAKUDO: Needed because of [perl #73912]
+class November { ... }
+
use November::Session;
use November::Cache;
use Digest;
@@ -39,15 +42,16 @@ class November does November::Session does November::Cache {
['out'], { self.log_out },
['register'], { self.register },
['recent'], { self.list_recent_changes },
- ['history'], { self.view_page_history(~$^page) },
+ ['history', /^ <-[?/]>+ $/], { self.view_page_history(~$^page) },
['all'], { self.list_all_pages },
];
my @chunks = $cgi.uri.chunks.list;
$d.dispatch(@chunks);
}
- method view_page($page is rw='Main_Page') {
+ # RAKUDO: Should `is rw` work with constant defaults? (It doesn't.)
+ method view_page($page is copy = 'Main_Page') {
$page .= subst('%20', '_', :g);
unless $.storage.wiki_page_exists($page) {
@@ -92,7 +96,7 @@ class November does November::Session does November::Cache {
}
- method edit_page($page is rw) {
+ method edit_page($page is copy) {
$page .= subst('%20', '_', :g);
my $sessions = self.read_sessions();
@@ -187,7 +191,9 @@ class November does November::Session does November::Cache {
}
method read_users {
- return {} unless $.config.userfile_path ~~ :e;
+ # RAKUDO: NYI ~~ :X file
+ #return {} unless $.config.userfile_path ~~ :e;
+ return {} unless $.config.userfile_path.IO.e;
return eval( slurp( $.config.userfile_path ) );
}
@@ -281,7 +287,7 @@ class November does November::Session does November::Cache {
}
method error_page($message = "An internal error occurred. Apologies.") {
- self.response( 'error.tmpl', { MESSAGE => $message } );
+ self.response( 'error.tmpl', { MESSAGE => $message ~ "<pre>{self.perl}</pre>" } );
}
method list_recent_changes {
@@ -292,7 +298,7 @@ class November does November::Session does November::Cache {
);
}
- method view_page_history($page is rw = 'Main_Page') {
+ method view_page_history($page is copy = 'Main_Page') {
$page .= subst('%20', '_', :g);
unless $.storage.wiki_page_exists($page) {
@@ -305,7 +311,7 @@ class November does November::Session does November::Cache {
self.response('page_history.tmpl',
{
'TITLE' => $title,
- 'CHANGES' => self.get_changes($page, limit => 50),
+ 'CHANGES' => self.get_changes(:$page, limit => 50),
}
);
}
@@ -367,8 +373,9 @@ class November does November::Session does November::Cache {
self.response('list_all_pages.tmpl', %params);
}
- # RAKUDO: die at hash merge if %params undef, so I use default value
- method response ($tmpl, %params?={}, %opts?) {
+ # RAKUDO: Instead of %params? we do %params = {}, because the former
+ # doesn't quite work. [perl #79642]
+ method response ($tmpl, %params = {}, %opts = {}) {
my $template = HTML::Template.from_file($.config.template_path ~ $tmpl);
$template.with_params(
@@ -389,9 +396,9 @@ class November does November::Session does November::Cache {
my $root = $!config.web_root;
if $title {
if $page ~~ m/':'/ {
- return qq|<a href="{ $root ~ $page }">$title</a>|;
+ return qq|<a href="{ $root ~ $page }">{$title}</a>|;
} else {
- return qq|<a href="$root/view/$page">$title</a>|;
+ return qq|<a href="$root/view/$page">{$title}</a>|;
}
} else {
return sprintf('<a href="%s/%s/%s" %s >%s</a>',
@@ -405,9 +412,9 @@ class November does November::Session does November::Cache {
method make_extlink($url, $title) {
if $title {
- return qq|<a href="$url">$title</a>|;
+ return qq|<a href="$url">{$title}</a>|;
} else {
- return qq|<a href="$url">$url</a>|;
+ return qq|<a href="$url">{$url}</a>|;
}
}
}
View
@@ -112,7 +112,7 @@ class November::CGI {
}
}
- sub unescape($string is rw) {
+ our sub unescape($string is copy) {
$string .= subst('+', ' ', :g);
# RAKUDO: This could also be rewritten as a single .subst :g call.
# ...when the semantics of .subst is revised to change $/,
View
@@ -15,14 +15,14 @@ method set-cache-entry( $key, $value ) {
method get-cache-entry( $key ) {
my $file = self.cache-dir ~ '/' ~ $key;
- return Nil unless $file ~~ :e;
+ return Nil unless $file.IO ~~ :e;
my $string = slurp( $file );
return $string;
}
method remove-cache-entry( $key ) {
my $file = self.cache-dir ~ '/' ~ $key;
- return unless $file ~~ :e;
+ return unless $file.IO ~~ :e;
unlink( $file );
}
View
@@ -17,7 +17,7 @@ method remove_session($id) {
}
method read_sessions {
- return {} unless self.sessionfile-path ~~ :e;
+ return {} unless self.sessionfile-path.IO ~~ :e;
my $string = slurp( self.sessionfile-path );
my $stuff = eval( $string );
return $stuff;
@@ -26,11 +26,11 @@ class November::Storage::File is November::Storage {
}
method wiki_page_exists($page) {
- return ($.content_path ~ $page) ~~ :e;
+ return ($.content_path ~ $page).IO ~~ :e;
}
method read_recent_changes {
- return [] unless $.recent_changes_path ~~ :e;
+ return [] unless $.recent_changes_path.IO ~~ :e;
return eval( slurp( $.recent_changes_path ) );
}
@@ -42,7 +42,7 @@ class November::Storage::File is November::Storage {
method read_page_history($page) {
my $file = $.content_path ~ $page;
- return [] unless $file ~~ :e;
+ return [] unless $file.IO ~~ :e;
my $page_history = eval( slurp($file) );
return $page_history;
}
@@ -56,7 +56,7 @@ class November::Storage::File is November::Storage {
method read_modification($modification_id) {
my $file = $.modifications_path ~ $modification_id;
- return [] unless $file ~~ :e;
+ return [] unless $file.IO ~~ :e;
return eval( slurp($file) );
}
View
@@ -4,9 +4,10 @@ use November::Config;
class November::Tags {
my $server_root = November::Config.new.server_root;
- my $.page_tags_path is rw = $server_root ~ 'data/page_tags/';
- my $.tags_count_path is rw = $server_root ~ 'data/tags_count';
- my $.tags_index_path is rw = $server_root ~ 'data/tags_index';
+ # TODO Nasty hack to enable testing to use different paths
+ has $.page_tags_path is rw = $server_root ~ 'data/page_tags/';
+ has $.tags_count_path is rw = $server_root ~ 'data/tags_count';
+ has $.tags_index_path is rw = $server_root ~ 'data/tags_index';
method update_tags($_: Str $page, Str $new_tags) {
my $old_tags = .read_page_tags($page).chomp;
@@ -37,7 +38,9 @@ class November::Tags {
}
unless any($index{$t}.values) eq $page {
$index{$t}.push($page);
- $index{$t} = grep { $_ ne '' }, $index{$t}.values;
+ # RAKUDO: bug w/ var on both lhs and rhs
+ my @tmp = grep { $_ ne '' }, $index{$t}.values;
+ $index{$t} = @tmp;
}
}
@@ -64,15 +67,17 @@ class November::Tags {
# RAKUDO: @ not implemented yet
#if $index{$t} && any(@ $index{$t}) eq $page {
if $index{$t} && any($index{$t}.values) eq $page {
- $index{$t} = grep { $_ ne $page }, $index{$t}.values;
+ # RAKUDO: bug w/ var on both lhs and rhs
+ my @tmp = grep { $_ ne $page }, $index{$t}.values;
+ $index{$t} = @tmp;
}
}
self.write_tags_index($index);
}
method read_page_tags(Str $page) {
my $file = $.page_tags_path ~ $page;
- return '' unless $file ~~ :e;
+ return '' unless $file.IO ~~ :e;
return slurp($file);
}
@@ -85,7 +90,7 @@ class November::Tags {
method read_tags_count() {
my $file = $.tags_count_path;
- return {} unless $file ~~ :e;
+ return {} unless $file.IO ~~ :e;
return eval slurp $file;
}
@@ -98,14 +103,14 @@ class November::Tags {
method read_tags_index() {
my $file = $.tags_index_path;
- return {} unless $file ~~ :e;
+ return {} unless $file.IO ~~ :e;
return eval slurp $file;
}
method write_tags_index(Hash $index) {
my $file = $.tags_index_path;
my $fh = open( $file, :w );
- $fh.say( $index.perl );
+- $fh.say( $index.perl );
$fh.close;
}
Oops, something went wrong.

0 comments on commit d1dd917

Please sign in to comment.