From 6bb2c391746a3d8b48379c348014b78fa53ca086 Mon Sep 17 00:00:00 2001 From: Timothy Totten <2010@huri.net> Date: Wed, 6 Mar 2013 12:12:22 -0800 Subject: [PATCH 1/3] Updated META.info and README to reflect new Web project coming shortly. --- META.info | 4 ++-- README | 6 ++++++ 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/META.info b/META.info index f8d12fa..1d3c91d 100644 --- a/META.info +++ b/META.info @@ -1,7 +1,7 @@ { - "name" : "Web", + "name" : "Web::Incubator", "version" : "*", - "description" : "A Perl 6 web framework", + "description" : "The old Web project, saved for historical purposes.", "depends" : ["HTTP::Daemon", "Perl6::Sqlite"], "source-url" : "git://github.com/masak/web.git" } diff --git a/README b/README index 3dbaa12..e100689 100644 --- a/README +++ b/README @@ -1,3 +1,9 @@ +NOTE: This project is now archived for historical purposes. + Please see https://github.com/supernovus/perl6-web/ for the new + Perl 6 Web project. + +--------------------------------------------------------------------------- + Web.pm is an incubator for several related but independent web application projects. It's united by one central goal: to bring web application crafting, just like the rest of Perl 6, up-to-date with current practices that have From 894a8bdc712fc1d922f4d471b77798416fbeae19 Mon Sep 17 00:00:00 2001 From: Timothy Totten <2010@huri.net> Date: Wed, 6 Mar 2013 13:31:31 -0800 Subject: [PATCH 2/3] See log. * Removed module-related files, this is now a reference only repo. * Moved Squerl into its own project repository. --- Configure | 3 - META.info | 7 - Makefile.in | 24 --- README | 2 + deps.proto | 3 - lib/Squerl.pm | 404 ------------------------------------- t/squerl/01-sqlite-write.t | 28 --- t/squerl/02-dataset.t | 327 ------------------------------ 8 files changed, 2 insertions(+), 796 deletions(-) delete mode 100644 Configure delete mode 100644 META.info delete mode 100644 Makefile.in delete mode 100644 deps.proto delete mode 100644 lib/Squerl.pm delete mode 100644 t/squerl/01-sqlite-write.t delete mode 100644 t/squerl/02-dataset.t diff --git a/Configure b/Configure deleted file mode 100644 index af81f34..0000000 --- a/Configure +++ /dev/null @@ -1,3 +0,0 @@ -#!perl6 -use v6; -use Configure; diff --git a/META.info b/META.info deleted file mode 100644 index 1d3c91d..0000000 --- a/META.info +++ /dev/null @@ -1,7 +0,0 @@ -{ - "name" : "Web::Incubator", - "version" : "*", - "description" : "The old Web project, saved for historical purposes.", - "depends" : ["HTTP::Daemon", "Perl6::Sqlite"], - "source-url" : "git://github.com/masak/web.git" -} diff --git a/Makefile.in b/Makefile.in deleted file mode 100644 index e28eecb..0000000 --- a/Makefile.in +++ /dev/null @@ -1,24 +0,0 @@ -PERL6= -RAKUDO_DIR= -PERL6LIB=':$(RAKUDO_DIR)' - -SOURCES=lib/Routes.pm lib/Routes/Route.pm \ - lib/Tags.pm lib/Test.pm \ - lib/Web/Nibbler.pm \ - lib/Web/Utils.pm \ - lib/Web/Request.pm lib/Web/Response.pm \ - lib/Web/Handler/HTTPDaemon.pm \ - lib/Astaire.pm lib/Squerl.pm lib/Ratel.pm - -PIRS=$(SOURCES:.pm=.pir) - -all: $(PIRS) - -%.pir: %.pm - env PERL6LIB=$(PERL6LIB) $(PERL6) --target=pir --output=$@ $< - -clean: - rm -f $(PIRS) - -test: all - env PERL6LIB=$(PERL6LIB) prove -e '$(PERL6)' -r --nocolor t/ diff --git a/README b/README index e100689..63f538b 100644 --- a/README +++ b/README @@ -26,6 +26,8 @@ Squerl manipulate queries in a flexible way. Not really an ORM layer, it's more of an abstraction of SQL specifics and platform differences. + Now moved into its own repo: https://github.com/supernovus/squerl/ + Ratel A no-frills templating module. Write your HTML (or whatever), and inline Perl 6 code between a '[%' and a '%]'. Ratel will turn your template into diff --git a/deps.proto b/deps.proto deleted file mode 100644 index d58fef0..0000000 --- a/deps.proto +++ /dev/null @@ -1,3 +0,0 @@ -# These are the dependencies needed by Web.pm -http-daemon -perl6-sqlite diff --git a/lib/Squerl.pm b/lib/Squerl.pm deleted file mode 100644 index 2679dbe..0000000 --- a/lib/Squerl.pm +++ /dev/null @@ -1,404 +0,0 @@ -use SQLite3; - -class Squerl::BooleanExpression { - has Str $.op; - has $.rhs; - has $.lhs; - - method Str() { "($.rhs $.op $.lhs)" } -} - -class Squerl::NumericExpression { - has $.expr; - - # RAKUDO: Due to a custom-defined infix:<< < >> causing #66552, - # we're going to do it like this for the time being. - method lt($lhs) { - Squerl::BooleanExpression.new(:op<< < >>, :rhs(self), :$lhs); - } - - method gt($lhs) { - Squerl::BooleanExpression.new(:op<< > >>, :rhs(self), :$lhs); - } - - method Str() { ~$.expr } -} - -class Squerl::LiteralString { - has Str $.value; - - method new($value) { self.bless(self.CREATE(), :$value) } - method Str() { ~$.value } -} - -sub sql_number($column) { - Squerl::NumericExpression.new(:expr($column)); -} - -# Ruby has symbols, Perl 6 doesn't. This class stands in as an -# impedance matcher. -class Squerl::Symbol { - has Str $.name; - - method new($name) { - self.bless(self.CREATE(), :$name); - } - - method Str() { - $.name; - } -} - -sub ident($name) { - Squerl::Symbol.new($name); -} - -class Squerl::InvalidOperation is Exception { - has $.message; - - multi method new($message) { - self.bless(*, :$message); - } - - method Str() { - "{self.WHAT}: $!message"; - } -} - -class Squerl::Dataset does Positional { - has $.db; - has %.opts; - # RAKUDO: Cannot type this attribute as Bool - has $.quote_identifiers is rw; - has Str $.identifier_input_method is rw; - has Str $.identifier_output_method is rw; - has &.row_proc is rw; - - my $COMMA_SEPARATOR = ', '; - - multi method new($db, :$quote_identifiers, - :$identifier_input_method, :$identifier_output_method, - :$row_proc, - *%opts) { - self.bless(self.CREATE(), :$db, :$quote_identifiers, - :$identifier_input_method, - :$identifier_output_method, - :$row_proc, - :%opts); - } - - multi method clone(*%opts) { - my %new-opts = %!opts, %opts; - self.bless(self.CREATE(), :db($!db), - :quote_identifiers($!quote_identifiers), - :identifier_input_method( - $!identifier_input_method - ), - :identifier_output_method( - $!identifier_output_method - ), - :row_proc(&!row_proc), - :opts(%new-opts)); - } - - method from(*@tables) { - self.clone(:from(@tables.elems > 1 ?? @tables !! @tables[0])); - } - - method filter($value) { - self.clone(:where($value)); - } - - method exists() { - Squerl::LiteralString.new("(EXISTS ({self.select_sql}))"); - } - - method insert(*@positionals, *%nameds) { - given $!db { - .open; - # RAKUDO: Real string interpolation - .exec(self.insert_sql(|@positionals, |%nameds)); - .close; - } - } - - method delete() { - given $!db { - .open; - # RAKUDO: Real string interpolation - .exec(self.delete_sql()); - .close; - } - } - - method update(*@pairs) { - given $!db { - .open; - # RAKUDO: Real string interpolation - .exec(self.update_sql(|@pairs)); - .close; - } - } - - method all() { - $!db.do-select(self.select_sql()).list; - } - - # RAKUDO: Strange Parrot global namespace bug - method llist() { - $!db.do-select(self.select_sql()).list; - } - - method literal($value? is copy) { - $value //= %_.pairs[0]; - given $value { - when Int { return literal_integer($value) } - when Num { return literal_number($value) } - when Squerl::Symbol { return self.literal_symbol($value) } - when Squerl::LiteralString { return $value.Str } - when Str { return literal_string($value) } - when Pair { return self.literal_pair($value) } - when Squerl::BooleanExpression { $value.Str } - default { die "Can't handle {$value.WHAT}" } - } - } - - method literal_pair($pair) { - sprintf '(%s = %s)', $pair.key, self.literal($pair.value); - } - - method literal_symbol($name is copy) { - $!identifier_input_method - = { 'upcase' => 'uc', 'downcase' => 'lc', - 'reverse' => 'flip' }.{$!identifier_input_method} - // $!identifier_input_method; - if $!identifier_input_method { - # RAKUDO: Would like to have spaces around the operator: - # [perl #69204] - $name.="$!identifier_input_method"; - } - $!quote_identifiers ?? quoted_identifier($name) !! $name; - } - - submethod literal_array(@values) { - "({join $COMMA_SEPARATOR, map { self.literal($^value) }, @values})"; - } - - sub literal_integer($value) { - ~$value - } - - sub literal_number($value) { - ~$value - } - - sub literal_string($value) { - "'{$value.subst('\\', '\\\\', :g).subst("'", "''", :g)}'" - } - - sub quoted_identifier($name) { - qq["{$name.subst(q["], q[""], :g)}"] - } - - method output_identifier($name is copy) { - $!identifier_output_method - = { 'upcase' => 'uc', 'downcase' => 'lc', - 'reverse' => 'flip' }.{$!identifier_output_method} - // $!identifier_output_method; - if $!identifier_output_method { - # RAKUDO: Would like to have spaces around the operator: - # [perl #69204] - $name.="$!identifier_output_method"; - } - $name; - } - - method static_sql($sql) { - $sql - } - - method check_modification_allowed() { - die ~Squerl::InvalidOperation.new('Joined datasets cannot be modified') - if %!opts ~~ Array && %!opts.elems > 1; - } - - sub source_list(@source) { - die 'No source specified for query' - if !defined @source || !@source; - - @source.join($COMMA_SEPARATOR); - } - - method sql() { - self.select_sql(); - } - - method select_sql() { - return self.static_sql(%!opts) - if %!opts.exists('sql'); - - # RAKUDO: Real string interpolation - "SELECT * FROM {source_list(%!opts.list)}" - ~ (%!opts.exists('where') - ?? " WHERE {self.literal(%!opts)}" - !! ''); - } - - method delete_sql() { - return self.static_sql(%!opts) - if %!opts.exists('sql'); - - self.check_modification_allowed(); - - # RAKUDO: Real string interpolation - "DELETE FROM {%!opts}" - ~ (%!opts.exists('where') - ?? " WHERE {self.literal(%!opts)}" - !! ''); - } - - method truncate_sql() { - return self.static_sql(%!opts) - if %!opts.exists('sql'); - - self.check_modification_allowed(); - - # RAKUDO: Real string interpolation - "TRUNCATE TABLE {%!opts}"; - } - - method insert_sql(*@positionals, *%nameds) { - return self.static_sql(%!opts) - if %!opts.exists('sql'); - - self.check_modification_allowed(); - - my (@columns, @values); - for @positionals { - when Pair { - @columns.push(.key); - @values.push(.value); - } - when Num|Str|Squerl::Dataset { - @values.push($_); - } - when .^can('values') { - for .values.pairs { - die "Expected a Pair, got a {.WHAT}" - unless $_ ~~ Pair; - @columns.push(.key); - @values.push(.value); - } - } - } - for %nameds.pairs { - @columns.push(.key); - @values.push(.value); - } - my $columns = @columns ?? "({join $COMMA_SEPARATOR, @columns}) " - !! ''; - my $values = @values - ?? (@values[0] ~~ Squerl::Dataset - ?? @values[0].select_sql() - !! 'VALUES ' ~ self.literal_array(@values)) - !! 'DEFAULT VALUES'; - # RAKUDO: Real string interpolation - "INSERT INTO {%!opts} $columns$values"; - } - - method update_sql(*@pairs) { - return self.static_sql(%!opts) - if %!opts.exists('sql'); - - self.check_modification_allowed(); - - my $values = join $COMMA_SEPARATOR, map { - "{.key} = {self.literal(.value)}" - }, @pairs; - "UPDATE {%!opts} SET $values" - ~ (%!opts.exists('where') - ?? " WHERE {self.literal(%!opts)}" - !! ''); - } -} - -class Squerl::Database { - has $!file; - has $!dbh; - # RAKUDO: Cannot type this attribute as Bool - has $.quote_identifiers; - has Str $.identifier_input_method; - has Str $.identifier_output_method; - - method open() { - $!dbh = sqlite_open($!file); - } - - method close() { - $!dbh.close(); - } - - method exec($statement) { - my $sth = $!dbh.prepare($statement); - $sth.step(); - $sth.finalize(); - } - - method create_table($_: *@args) { - my $table-name = @args[0]; - my $columns = join ', ', gather for @args[1..^*] { - die "Expected a Pair, got a {.WHAT}" - unless $_ ~~ Pair; - my ($name, $type) = .key, .value; - given $type.lc { - when 'primary_key' { take "$name INTEGER PRIMARY KEY ASC" } - when 'int'|'integer' { take "$name INTEGER" } - when 'str'|'string' { take "$name TEXT" } - default { die "Unknown type $type" } - } - }; - .open; - .exec("CREATE TABLE $table-name ($columns)"); - .close; - } - - method select($what, $table) { - self.do-select("SELECT $what FROM $table"); - } - - method do-select($_: $query) { - my @rows; - .open; - my $sth = $!dbh.prepare($query); - while $sth.step() == 100 { - my %row; - # RAKUDO: Can't use hash indexing here. [perl #71064] - %row.push($sth.column_name($_) => $sth.column_text($_)) - for ^$sth.column_count(); - push @rows, {%row}; - } - .close; - return @rows; - } - - method from($table) { - return Squerl::Dataset.new(self, :from($table), - :quote_identifiers($!quote_identifiers), - :identifier_input_method( - $!identifier_input_method - ), - :identifier_output_method( - $!identifier_output_method - )); - } - - method postcircumfix:<{ }>($table) { - self.from($table); - } -} - -class Squerl { - method sqlite($file) { - return Squerl::Database.new(:$file); - } -} diff --git a/t/squerl/01-sqlite-write.t b/t/squerl/01-sqlite-write.t deleted file mode 100644 index 8b2a064..0000000 --- a/t/squerl/01-sqlite-write.t +++ /dev/null @@ -1,28 +0,0 @@ -use v6; -use Test; - -use Squerl; - -unlink (my $file = 't/squerl/posts.db'); -my $DB = Squerl.sqlite($file); - -$DB.create_table: 'posts', - 'id' => 'primary_key', - 'user_id' => 'Int', - 'name' => 'String', -; - -#my $posts = $DB; -my $posts = $DB.from('posts'); - -$posts.insert(0, 1, 'Hello Austria!'); - -ok $file ~~ :e, 'could create the database file'; - -my $number-of-posts = +$posts.all; - -is $number-of-posts, 1, 'could insert and then retrieve a row'; - -done_testing; - -unlink $file; diff --git a/t/squerl/02-dataset.t b/t/squerl/02-dataset.t deleted file mode 100644 index eae6091..0000000 --- a/t/squerl/02-dataset.t +++ /dev/null @@ -1,327 +0,0 @@ -use v6; -use Test; - -use Squerl; - -my $dataset = Squerl::Dataset.new('db'); - -# RAKUDO: There are plenty of unnecessary semicolons at the end of blocks -# in this file, due to [perl #69438] - -{ - my $db = 'db'; - my %opts = :from; - my $d = Squerl::Dataset.new($db, |%opts); - is $d.db, $db, 'attribtue .db was properly set'; - is_deeply $d.opts, %opts, 'attribute .opts was properly set'; - - $d = Squerl::Dataset.new($db); - is $d.db, $db, 'attribtue .db was properly set'; - ok $d.opts ~~ Hash, 'attribute .opts is a hash even when not set'; - is_deeply $d.opts, {}, 'attribute .opts is empty'; -}; - -{ - my $d1 = $dataset.clone( :from( ['test'] ) ); - is $d1.WHAT, $dataset.WHAT, 'clone has the same class as original'; - ok $d1 !=== $dataset, 'clone is distinct from original'; - ok $d1.db === $dataset.db, 'clone has the same .db attribute'; - is_deeply $d1.opts, ['test'], - 'the attribute passed with the .clone method is there'; - ok !$dataset.opts.exists('from'), 'the original is unchanged'; - - my $d2 = $d1.clone( :order( ['name'] ) ); - is $d2.WHAT, $dataset.WHAT, 'clone of clone has the class of original'; - ok $d2 !=== $d1, 'clone of clone is distinct from clone'; - ok $d2 !=== $dataset, 'clone of clone is distinct from original'; - ok $d2.db === $dataset.db, 'clone of clone has the same .db attribute'; - is_deeply $d2.opts, ['test'], - 'the attribute from the first clone is preserved in the second'; - is_deeply $d2.opts, ['name'], - 'the attribute passed with the .clone method is there'; - ok !$d1.opts.exists('order'), 'the original clone is unchanged'; -}; - -{ - ok Squerl::Dataset ~~ Positional, 'you can index into Squerl::Dataset'; -}; - -{ - my $db = Squerl::Database.new( :quote_identifiers ); - ok $db.from('a').quote_identifiers, - 'should get quote_identifiers default from database I'; - $db = Squerl::Database.new( :!quote_identifiers ); - nok $db.from('a').quote_identifiers, - 'should get quote_identifiers default from database II'; -}; - -{ - my $db = Squerl::Database.new( :identifier_input_method ); - ok $db.from('a').identifier_input_method eq 'upcase', - 'should get identifier_input_method default from database I'; - $db = Squerl::Database.new( :identifier_input_method ); - ok $db.from('a').identifier_input_method eq 'downcase', - 'should get identifier_input_method default from database II'; -}; - -{ - my $db = Squerl::Database.new( :identifier_output_method ); - ok $db.from('a').identifier_output_method eq 'upcase', - 'should get identifier_output_method default from database I'; - $db = Squerl::Database.new( :identifier_output_method ); - ok $db.from('a').identifier_output_method eq 'downcase', - 'should get identifier_output_method default from database II'; -}; - -$dataset = Squerl::Dataset.new('db'); - -{ - $dataset.quote_identifiers = True; - is $dataset.literal(ident('a')), '"a"', - 'setting quote_identifiers to True makes .literal quote identifiers'; - $dataset.quote_identifiers = False; - is $dataset.literal(ident('a')), 'a', - 'setting quote_identifiers to False makes .literal ' - ~ 'not quote identifiers'; -}; - -{ - $dataset.identifier_input_method = 'upcase'; - is $dataset.literal(ident('a')), 'A', - 'identifier_input_method changes literalization of identifiers I'; - $dataset.identifier_input_method = 'downcase'; - is $dataset.literal(ident('A')), 'a', - 'identifier_input_method changes literalization of identifiers II'; - $dataset.identifier_input_method = 'reverse'; - is $dataset.literal(ident('at_b')), 'b_ta', - 'identifier_input_method changes literalization of identifiers III'; - - $dataset.identifier_input_method = 'uc'; - is $dataset.literal(ident('a')), 'A', - 'identifier_input_method changes literalization of identifiers IV'; - $dataset.identifier_input_method = 'lc'; - is $dataset.literal(ident('A')), 'a', - 'identifier_input_method changes literalization of identifiers V'; - $dataset.identifier_input_method = 'flip'; - is $dataset.literal(ident('at_b')), 'b_ta', - 'identifier_input_method changes literalization of identifiers VI'; -}; - -{ - is $dataset.output_identifier('at_b_C'), 'at_b_C', - 'identifier_output_method changes identifiers returned from the db I'; - - $dataset.identifier_output_method = 'upcase'; - is $dataset.output_identifier('at_b_C'), 'AT_B_C', - 'identifier_output_method changes identifiers returned from the db II'; - $dataset.identifier_output_method = 'downcase'; - is $dataset.output_identifier('at_b_C'), 'at_b_c', - 'identifier_output_method changes identifiers returned from the db III'; - $dataset.identifier_output_method = 'reverse'; - is $dataset.output_identifier('at_b_C'), 'C_b_ta', - 'identifier_output_method changes identifiers returned from the db IV'; - - $dataset.identifier_output_method = 'uc'; - is $dataset.output_identifier('at_b_C'), 'AT_B_C', - 'identifier_output_method changes identifiers returned from the db V'; - $dataset.identifier_output_method = 'lc'; - is $dataset.output_identifier('at_b_C'), 'at_b_c', - 'identifier_output_method changes identifiers returned from the db VI'; - $dataset.identifier_output_method = 'flip'; - is $dataset.output_identifier('at_b_C'), 'C_b_ta', - 'identifier_output_method changes identifiers returned from the db VII'; -}; - -$dataset = Squerl::Dataset.new(undef).from('items'); - -{ - $dataset.row_proc = { $^r }; - my $clone = $dataset.clone; - - ok $clone !=== $dataset, 'the clone is not the original'; - is $clone.WHAT, $dataset.WHAT, 'clone has the same type as original'; - is_deeply $clone.opts, $dataset.opts, 'opts attributes are equivalent'; - ok $clone.row_proc === $dataset.row_proc, 'row_proc attributes equal'; -}; - -{ - my $clone = $dataset.clone; - - ok $clone.opts !=== $dataset.opts, 'cloning deep-copies .opts'; - $dataset.=filter( 'a' => 'b' ); - ok !$clone.opts.exists('filter'), - 'changing original.opts leaves clone.opts unchanged'; -}; - -{ - my $clone = $dataset.clone; - - is $clone.WHAT, $dataset.WHAT, 'should return a clone self I'; - is $clone.db, $dataset.db, 'should return a clone self II'; - is_deeply $clone.opts, $dataset.opts, 'should return a clone self III'; -}; - -$dataset = Squerl::Dataset.new(undef).from('items'); - -{ - my $clone = $dataset.clone( one => 2 ); - - is_deeply $clone.opts, { one => 2, from => 'items' }, - 'should merge the specified options'; -}; - -{ - my $clone = $dataset.clone( :from(['other']) ); - - is_deeply $clone.opts, { :from(['other']) }, - 'should overwrite existing options'; -}; - -{ - my $clone = $dataset.clone( :from(['other']) ); - - is_deeply $dataset.opts, 'items', 'original .opts unharmed'; - is_deeply $clone.opts, ['other'], 'cloned .opts changed' -}; - -{ - # TODO: Can't realisticly do this one yet. - - # m = Module.new do - # def __xyz__; "xyz"; end - # end - # @dataset.extend(m) - # @dataset.clone({}).should respond_to(:__xyz__) -}; - -$dataset = Squerl::Dataset.new(undef).from('test'); - -is $dataset.select_sql, 'SELECT * FROM test', 'format a select statement'; -is $dataset.delete_sql, 'DELETE FROM test', 'format a delete statement'; -is $dataset.truncate_sql, 'TRUNCATE TABLE test', 'format a truncate statement'; -is $dataset.insert_sql, 'INSERT INTO test DEFAULT VALUES', - 'format an insert statement with default values'; - -{ - my $sql = $dataset.insert_sql(:name, :price(342)); - ok $sql eq q[INSERT INTO test (name, price) VALUES ('wxyz', 342)] - | q[INSERT INTO test (price, name) VALUES (342, 'wxyz')], - 'format an insert statement with hash'; - is $dataset.insert_sql({}), 'INSERT INTO test DEFAULT VALUES', - 'empty hash gives an insert statement with default values'; -}; - -{ - my $sql = $dataset.insert_sql( 'name' => 'wxyz', 'price' => 342 ); - ok $sql eq q[INSERT INTO test (name, price) VALUES ('wxyz', 342)] - | q[INSERT INTO test (price, name) VALUES (342, 'wxyz')], - 'format an insert statement with string keys'; -}; - -role R1 { method values { 'a' => 1; } } -role R2 { method values { {} } }; - -{ - my $v = Object.new but R1; - is $dataset.insert_sql($v), 'INSERT INTO test (a) VALUES (1)', - 'format an insert statement with an object that .can("values") I'; - - $v = Object.new but R2; - is $dataset.insert_sql($v), 'INSERT INTO test DEFAULT VALUES', - 'format an insert statement with an object that .can("values") II'; -}; - -{ - is $dataset.insert_sql(123), 'INSERT INTO test VALUES (123)', - 'format an insert statement with an arbitrary value'; -}; - -{ - my $sub = Squerl::Dataset.new('').from('something').filter('x' => 2); - is $dataset.insert_sql($sub), - 'INSERT INTO test SELECT * FROM something WHERE (x = 2)', - 'format an insert statement with sub-query'; -}; - -{ - is $dataset.insert_sql('a', 2, 6.5), - q[INSERT INTO test VALUES ('a', 2, 6.5)], - 'format an insert statement with array'; -}; - -{ - is $dataset.update_sql('name' => 'abc'), - q[UPDATE test SET name = 'abc'], - 'format an update statement'; -}; - -{ - is $dataset.clone(:sql('xxx yyy zzz')).select_sql(), 'xxx yyy zzz', - 'return rows for arbitrary SQL'; -}; - -{ - my $sql = 'X'; - my $ds = Squerl::Dataset.new(undef, :$sql); - is $ds.select_sql(), $sql, ':sql option works for .select_sql'; - is $ds.insert_sql(), $sql, ':sql option works for .insert_sql'; - is $ds.delete_sql(), $sql, ':sql option works for .delete_sql'; - is $ds.update_sql(), $sql, ':sql option works for .update_sql'; - is $ds.truncate_sql(), $sql, ':sql option works for .truncate_sql'; -}; - -sub throws_exception(&block, $expected-type, $message = '') { - try { - &block(); - } - if $! { - my $got-type = ~$!; - ok $got-type.substr(0, $expected-type.chars) eq $expected-type, - $message; - } - else { - is 'ran without failure', $expected-type, $message; - } -} - -$dataset = Squerl::Dataset.new(undef).from('t1', 't2'); - -todo('not implemented yet', 4); -{ - throws_exception { $dataset.update_sql( a => 1 ) }, - 'Squerl::InvalidOperation', - 'multi-table dataset dies on .update_sql'; - - throws_exception { $dataset.delete_sql() }, - 'Squerl::InvalidOperation', - 'multi-table dataset dies on .delete_sql'; - - throws_exception { $dataset.truncate_sql() }, - 'Squerl::InvalidOperation', - 'multi-table dataset dies on .truncate_sql'; - - throws_exception { $dataset.insert_sql() }, - 'Squerl::InvalidOperation', - 'multi-table dataset dies on .insert_sql'; -}; - -{ - is $dataset.select_sql, 'SELECT * FROM t1, t2', - 'generate a select query FROM all specified tables'; -} - -my $ds1 = Squerl::Dataset.new(undef).from('test'); -# RAKUDO: A bug prevents us from writing this: -# my $ds2 = $ds1.filter(sql_number('price') < 100); -# my $ds3 = $ds1.filter(sql_number('price') > 50); -my $ds2 = $ds1.filter(sql_number('price').lt(100)); -my $ds3 = $ds1.filter(sql_number('price').gt(50)); - -{ - is $ds1.filter($ds2.exists).sql, - 'SELECT * FROM test WHERE (EXISTS ' - ~ '(SELECT * FROM test WHERE (price < 100)))', - 'Dataset#exists works in filters'; -} - -done_testing; From 36a1601d92077097a3ad8252ff5db959c48a2e35 Mon Sep 17 00:00:00 2001 From: Timothy Totten <2010@huri.net> Date: Wed, 6 Mar 2013 13:53:50 -0800 Subject: [PATCH 3/3] Hitomi is now Hinges, and is a standalone project. --- README | 3 + drafts/hitomi | 110 ------------ drafts/hitomi-example.xml | 26 --- lib/Hitomi.pm | 7 - lib/Hitomi/Attrs.pm | 4 - lib/Hitomi/HTMLParser.pm | 9 - lib/Hitomi/Input.pm | 11 -- lib/Hitomi/Interpolation.pm | 41 ----- lib/Hitomi/Markup.pm | 122 -------------- lib/Hitomi/Output.pm | 50 ------ lib/Hitomi/Stream.pm | 43 ----- lib/Hitomi/StreamEventKind.pm | 3 - lib/Hitomi/StringIO.pm | 5 - lib/Hitomi/XMLParser.pm | 80 --------- t/hitomi/01-xml-parsing.t | 32 ---- t/hitomi/02-substitution.t | 32 ---- t/hitomi/03-if.t | 26 --- t/hitomi/04-for.t | 38 ----- t/hitomi/05-input.t | 308 ---------------------------------- t/hitomi/06-markup.t | 252 ---------------------------- 20 files changed, 3 insertions(+), 1199 deletions(-) delete mode 100644 drafts/hitomi delete mode 100644 drafts/hitomi-example.xml delete mode 100644 lib/Hitomi.pm delete mode 100644 lib/Hitomi/Attrs.pm delete mode 100644 lib/Hitomi/HTMLParser.pm delete mode 100644 lib/Hitomi/Input.pm delete mode 100644 lib/Hitomi/Interpolation.pm delete mode 100644 lib/Hitomi/Markup.pm delete mode 100644 lib/Hitomi/Output.pm delete mode 100644 lib/Hitomi/Stream.pm delete mode 100644 lib/Hitomi/StreamEventKind.pm delete mode 100644 lib/Hitomi/StringIO.pm delete mode 100644 lib/Hitomi/XMLParser.pm delete mode 100644 t/hitomi/01-xml-parsing.t delete mode 100644 t/hitomi/02-substitution.t delete mode 100644 t/hitomi/03-if.t delete mode 100644 t/hitomi/04-for.t delete mode 100644 t/hitomi/05-input.t delete mode 100644 t/hitomi/06-markup.t diff --git a/README b/README index 63f538b..5c1d684 100644 --- a/README +++ b/README @@ -39,6 +39,9 @@ Hitomi XML SAX streams, it allows for combining (X)HTML and Perl 6 code in the same template. + This is now known as Hinges, and can be found in its own repository: + https://github.com/supernovus/hinges/ + Contact ======= diff --git a/drafts/hitomi b/drafts/hitomi deleted file mode 100644 index 496f05e..0000000 --- a/drafts/hitomi +++ /dev/null @@ -1,110 +0,0 @@ -use v6; - -grammar XML { - regex TOP { ^ * + {*} $ }; - - token xmlcontent { - | {*} #= node - | {*} #= empty - | {*} #= content - }; - - rule node { - '<' '>' - + - ' '>' - {*} - } - - rule pi { ' <.ident> '>' }; - - rule empty { '<' '/>' {*} }; - - token attrs { * {*} } - rule attr { $=[<.ident>[':'<.ident>]?] '=' '"' $=[<-["]>+] '"' } - - token ident { <+alnum + [\-]>+ } - - regex content { <-[<]>+ {*} } -}; -class XML::Actions { - my $h = -> $/ { - make [~] gather { - for $/.chunks{ - if .key eq '~' { - take .value; - } else { - take .value.ast; - } - } - } - } - method TOP($/) { - $h($/); - } - - method xmlcontent($/, $key) { - $h($/); - } - - method node($/) { - if $ { - for $ -> $a { - if $a eq "pe:if" { - make eval(~$a) ?? matching-if($/) !! q[]; - return; - } - elsif $a ~~ /^ 'pe:'/ { - make "Unknown 'pe:' attribute!"; - return; - } - } - } - $h($/); - } - - method empty($/) { - $h($/); - } - - method attrs($/) { - $h($/); - } - method content($/) { - make ~$/; - } - - sub matching-if($/) { - return $/.ast; - } -} - -# RAKUDO: Arguably wrong that this has to be here and not in the class. -# [perl #65238] -sub links() { - return [ - { - :url, - :title("ihrd's blog"), - :username, - :time(1240904601) - }, - { :url, - :title("Tene's blog"), - :username, - :time(1240905184), - }, - { :url, - :title("masak's blog"), - :username, - :time(1240905293), - }, - ]; -} - - -my $xml = $*IN.slurp; -my $result = XML.parse($xml, :action(XML::Actions.new())); -print $result.ast; - -# vim: ft=perl6 diff --git a/drafts/hitomi-example.xml b/drafts/hitomi-example.xml deleted file mode 100644 index 6798b86..0000000 --- a/drafts/hitomi-example.xml +++ /dev/null @@ -1,26 +0,0 @@ - - - - Slurp: News - - - - -
    -
  1. - ${$link.title} - posted by ${$link.username} at ${strftime('%x %X', $link.time)} -
    2. -
- -

Submit new link

- - - - diff --git a/lib/Hitomi.pm b/lib/Hitomi.pm deleted file mode 100644 index 4ff145d..0000000 --- a/lib/Hitomi.pm +++ /dev/null @@ -1,7 +0,0 @@ -use v6; - -use Hitomi::XMLParser; -use Hitomi::Markup; - -class Hitomi::DocType::HTML5 { -} diff --git a/lib/Hitomi/Attrs.pm b/lib/Hitomi/Attrs.pm deleted file mode 100644 index 65ccb69..0000000 --- a/lib/Hitomi/Attrs.pm +++ /dev/null @@ -1,4 +0,0 @@ -use v6; - -class Hitomi::Attrs { -} diff --git a/lib/Hitomi/HTMLParser.pm b/lib/Hitomi/HTMLParser.pm deleted file mode 100644 index f9a7349..0000000 --- a/lib/Hitomi/HTMLParser.pm +++ /dev/null @@ -1,9 +0,0 @@ -use v6; - -class Hitomi::HTMLParser { - # RAKUDO: https://trac.parrot.org/parrot/ticket/536 makes the method - # override the global 'list' sub if we call it 'list' - method llist() { - return (); - } -} diff --git a/lib/Hitomi/Input.pm b/lib/Hitomi/Input.pm deleted file mode 100644 index 2a0c6e3..0000000 --- a/lib/Hitomi/Input.pm +++ /dev/null @@ -1,11 +0,0 @@ -use v6; - -use Hitomi::Stream; -use Hitomi::XMLParser; - -class ParseError { -} - -sub XML($text) { - return Hitomi::Stream.new(@(Hitomi::XMLParser.new($text))); -} diff --git a/lib/Hitomi/Interpolation.pm b/lib/Hitomi/Interpolation.pm deleted file mode 100644 index 99f7cb2..0000000 --- a/lib/Hitomi/Interpolation.pm +++ /dev/null @@ -1,41 +0,0 @@ -use Hitomi::StreamEventKind; - -grammar Hitomi::Interpolation::Grammar { - regex TOP { ^ * $ } - regex chunk { || } - - regex plain { [ .]+ } - regex expr { '$' [ | ] } - - regex ident { <.alpha> \w* } - regex identifier { <.ident> [ <.apostrophe> <.ident> ]* } - token apostrophe { <[ ' \- ]> } - - regex block { '{' '}' } - regex content { <-[{}]>+ } -} - -# Note: It _is_ possible for the above grammar to fail, even though it's -# probably not very desirable that it can. An example of a failing -# input is '$'. The way to fix this would likely be (1) see what -# Genshi does about broken input, (2) write Hitomi tests to do the -# same, (3) improve the grammar. - -sub interpolate($text, $filepath, $lineno = -1, $offset = 0, - $lookup = 'strict') { - - # TODO: Make it impossible to fail here. See the above note. - return $text - unless Hitomi::Interpolation::Grammar.parse($text); - - return gather for @($ // []) -> $chunk { - my $pos = [$filepath, $lineno, $offset]; - if $chunk -> $plain { - take [Hitomi::StreamEventKind::text, ~$plain, $pos]; - } - elsif $chunk -> $expr { - my $data = $expr ?? $expr !! $expr; - take [Hitomi::StreamEventKind::expr, ~$data, $pos]; - } - } -} diff --git a/lib/Hitomi/Markup.pm b/lib/Hitomi/Markup.pm deleted file mode 100644 index 4031237..0000000 --- a/lib/Hitomi/Markup.pm +++ /dev/null @@ -1,122 +0,0 @@ -use Hitomi::Stream; -use Hitomi::XMLParser; -use Hitomi::Interpolation; - -class Hitomi::Context { - # I see from the Genshi source that %!vars will eventually be replaced by - # @!frames. This suffices for now. - has %!vars; - - method new(*%nameds, *@pairs) { - my %vars = %nameds; - for @pairs { - %vars{.key} = .value; - } - return self.bless(*, :%vars); - } - - method get($thing is copy) { - if $thing ~~ /^ '$'/ { - $thing .= substr(1); - } - %!vars{$thing}; - } -} - -class Hitomi::Template { - has $!source; - has $!filepath; - has $!filename; - has $!loader; - has $!encoding; - has $!lookup; - has $!allow_exec; - has $!stream; - - submethod BUILD(:$source, :$filepath, :$filename, :$loader, - :$encoding, :$lookup, :$allow_exec) { - - $!source = $source; - $!filepath = $filepath; - $!filename = $filename; - $!loader = $loader; - $!encoding = $encoding; - $!loader = $loader; - $!allow_exec = $allow_exec; - - $!filepath //= $!filename; - - $!stream = self._parse($!source, $!encoding); - } - - method new($source, $filepath?, $filename?, $loader?, - $encoding?, $lookup = 'strict', $allow_exec = True) { - self.bless(*, - :$source, :$filepath, :$filename, :$loader, - :$encoding, :$lookup, :$allow_exec); - } - - method _parse($source, $encoding) { - ... - } - - method generate(*%nameds, *@pairs) { - my $context = Hitomi::Context.new(|%nameds, |@pairs); - return self._flatten($!stream, $context); - } - - method _flatten($stream, $context) { - my @newstream = gather for $stream.llist -> $event { - my ($kind, $data, $pos) = @($event); - if ($kind ~~ Hitomi::StreamEventKind::expr) { - take [Hitomi::StreamEventKind::text, - self._eval($data, $context), - $pos]; - } - else { - take [$kind, $data, $pos]; - } - }; - return Hitomi::Stream.new(@newstream); - } - - method _eval($data, $context) { - # Well, this works for expressions which consist of one variable - # and nothing more. Will expand later. - $context.get($data); - } -} - -class Hitomi::MarkupTemplate is Hitomi::Template { - submethod BUILD(:$!source, :$!filepath, :$!filename, :$!loader, - :$!encoding, :$!lookup, :$!allow_exec) { - } - - method _parse($source is copy, $encoding) { - if $source !~~ Hitomi::Stream { - $source = Hitomi::XMLParser.new($source, $!filename, $encoding); - } - - my @stream; - - for $source.llist -> @event { - my ($kind, $data, $pos) = @event; - - if $kind ~~ Hitomi::StreamEventKind::text { - @stream.push: - interpolate($data, $!filepath, $pos[1], $pos[2], $!lookup); - } - else { - @stream.push( [$kind, $data, $pos] ); - } - } - - return Hitomi::Stream.new(@stream); - } -} - -class Hitomi::Markup { - method new($text) { - return self.bless(*, :$text); - } -} diff --git a/lib/Hitomi/Output.pm b/lib/Hitomi/Output.pm deleted file mode 100644 index c794931..0000000 --- a/lib/Hitomi/Output.pm +++ /dev/null @@ -1,50 +0,0 @@ -use Hitomi::StreamEventKind; - -sub escape($text, :$quotes = True) { - $text; # TODO -} - -class Hitomi::XMLSerializer { - has @!filters; - - method serialize($stream) { - return join '', [~] gather for $stream.llist { - my ($kind, $data, $pos) = @($_); - if ($kind ~~ Hitomi::StreamEventKind::start - | Hitomi::StreamEventKind::empty) { - my ($tag, $attribs) = @($data); - take '<'; - take $tag; - for @($attribs) -> $attrib { - my ($attr, $value) = @($attrib); - take for ' ', $attr, q[="], escape($value), q["]; - } - take $kind ~~ Hitomi::StreamEventKind::empty ?? '/>' !! '>'; - } - elsif ($kind ~~ Hitomi::StreamEventKind::end) { - take sprintf '', $data; - } - else { # TODO More types - take escape($data, :!quotes); - } - } - } -} - -class Hitomi::XHTMLSerializer is Hitomi::XMLSerializer { -} - -class Hitomi::HTMLSerializer { -} - -class Hitomi::TextSerializer { -} - -sub get_serializer($method, *%_) { - my $class = ( :xml( Hitomi::XMLSerializer), - :xhtml( Hitomi::XHTMLSerializer), - :html( Hitomi::HTMLSerializer), - :text( Hitomi::TextSerializer) ){$method.lc}; - return $class.new(|%_); -} - diff --git a/lib/Hitomi/Stream.pm b/lib/Hitomi/Stream.pm deleted file mode 100644 index af15e55..0000000 --- a/lib/Hitomi/Stream.pm +++ /dev/null @@ -1,43 +0,0 @@ -use v6; -use Hitomi::StreamEventKind; -use Hitomi::Output; - -class Hitomi::Stream { - has @!events; - has $serializer; - - multi method new(@events, $serializer?) { - return self.new( - :events(@events), - :serializer($serializer // Hitomi::XHTMLSerializer.new()) - ); - } - - # RAKUDO: We shouldn't have to provide this method. It should be handed - # to us by C. - multi method new(*%_) { - return self.bless(self.CREATE(), |%_); - } - - method Str() { - # RAKUDO: A complex set of circumstances may cause the - # array to have been nested one level too deeply at - # this point. Compensating. - @!events = @(@!events[0]) - while @!events.elems == 1 && @!events[0] ~~ Array; - return $serializer.serialize(self); - } - - method llist() { - # RAKUDO: A complex set of circumstances may cause the - # array to have been nested one level too deeply at - # this point. Compensating. - @!events = @(@!events[0]) - while @!events.elems == 1 && @!events[0] ~~ Array; - return @!events; - } - - method render($format, :$doctype) { - return ""; - } -} diff --git a/lib/Hitomi/StreamEventKind.pm b/lib/Hitomi/StreamEventKind.pm deleted file mode 100644 index 011d047..0000000 --- a/lib/Hitomi/StreamEventKind.pm +++ /dev/null @@ -1,3 +0,0 @@ -enum Hitomi::StreamEventKind ; - diff --git a/lib/Hitomi/StringIO.pm b/lib/Hitomi/StringIO.pm deleted file mode 100644 index c792609..0000000 --- a/lib/Hitomi/StringIO.pm +++ /dev/null @@ -1,5 +0,0 @@ -use v6; - -class Hitomi::StringIO { -} - diff --git a/lib/Hitomi/XMLParser.pm b/lib/Hitomi/XMLParser.pm deleted file mode 100644 index aff8def..0000000 --- a/lib/Hitomi/XMLParser.pm +++ /dev/null @@ -1,80 +0,0 @@ -use v6; - -use Hitomi::Stream; - -grammar Hitomi::XMLGrammar { - regex TOP { ^ ? * $ }; - - token xmlcontent { - || - || - }; - - token element { - '<' '/>' - || - '<' '>' - + - ' '>' - } - - token attrs { * } - rule attr { $=[<.ident>[':'<.ident>]?] '=' '"' - $=[<-["]>+] '"' } # ' - token ident { <+alnum + [\-]>+ } - - regex textnode { <-[<]>+ {*} } - - token doctype { ' '>' } - token externalId { 'PUBLIC' } - token pubid { '"' $=[<-["]>+] '"' } - token system { '"' $=[<-["]>+] '"' } -} - -class Hitomi::XMLParser { - has $!text; - - method new($text, $filename?, $encoding?) { - return self.bless(*, :$text); - } - - submethod make-events(Match $m, $text) { - return () unless $m; - my @events; - for @($m // []) -> $d { - push @events, [Hitomi::StreamEventKind::doctype, *, *]; - } - for @($m) -> $part { - if $part -> $e { - my $data = [~$e, - [map {; ~. => convert-entities(~.) }, - $e ?? $e.list !! ()] - ]; - push @events, [Hitomi::StreamEventKind::start, $data, *], - self.make-events($e, $text), - [Hitomi::StreamEventKind::end, ~$e, *]; - } - elsif $part -> $t { - my $line-num = +$text.substr(0, $t.from).comb(/\n/) + 1; - my $pos = [Nil, $line-num, $t.from]; - my $tt = convert-entities(~$t); - push @events, [Hitomi::StreamEventKind::text, $tt, $pos]; - } - } - return @events; - } - - sub convert-entities($text) { - die "Unrecognized entity $0" - if $text ~~ / ('&' \w+ ';') /; - $text.subst(' ', "\x[a0]", :g) - } - - # RAKUDO: https://trac.parrot.org/parrot/ticket/536 makes the method - # override the global 'list' sub if we call it 'list' - method llist() { - Hitomi::XMLGrammar.parse($!text) or die "Couldn't parse $!text"; - my @actions = self.make-events($/, $!text); - return @actions; - } -} diff --git a/t/hitomi/01-xml-parsing.t b/t/hitomi/01-xml-parsing.t deleted file mode 100644 index 344efb2..0000000 --- a/t/hitomi/01-xml-parsing.t +++ /dev/null @@ -1,32 +0,0 @@ -use v6; - -use Test; -use Hitomi; - -my @valid-xml = - '', -# '', # todo -# '', # todo -; - -my @invalid-xml = -# '', # todo - '<', - '', - '', -; - -sub parse($text) { - my $succeeded = False; - try { - Hitomi::XMLParser.new($text).llist(); - $succeeded = True; - } - $succeeded; -} - -plan @valid-xml + @invalid-xml; - -ok parse($_), "$_ is valid" for @valid-xml; -nok parse($_), "$_ is invalid" for @invalid-xml; diff --git a/t/hitomi/02-substitution.t b/t/hitomi/02-substitution.t deleted file mode 100644 index 012851b..0000000 --- a/t/hitomi/02-substitution.t +++ /dev/null @@ -1,32 +0,0 @@ -use v6; -use Test; -use Hitomi; - -plan 2; - -todo('Hitomi::Stream.render not implemented yet', 2); -{ - my Hitomi::MarkupTemplate $template .= new(' -

Hello, $name!

- -'); - my Hitomi::Stream $stream = $template.generate( :name ); - is $stream.render('html', :doctype(Hitomi::DocType::HTML5)), - ' - -

Hello, world!

- -', 'simple variable substitution works'; -} - -{ - my Hitomi::MarkupTemplate $template .= new(' -

Hello, ${ $name }

-'); - my Hitomi::Stream $stream = $template.generate( :name ); - is $stream.render('html', :doctype(Hitomi::DocType::HTML5)), ' - -

Hello, world!

- -', 'dollar block substitution works'; -} diff --git a/t/hitomi/03-if.t b/t/hitomi/03-if.t deleted file mode 100644 index 6ab5733..0000000 --- a/t/hitomi/03-if.t +++ /dev/null @@ -1,26 +0,0 @@ -use v6; -use Test; -use Hitomi; - -plan 2; - -todo('Hitomi::Stream.render not implemented yet', 2); -{ - my Hitomi::MarkupTemplate $template .= new(' -

Hello, world!

- -'); - is $template.generate( :flag(True) ).render('html', - :doctype(Hitomi::DocType::HTML5)), - ' - -

Hello, world!

- -', 'true if statement works'; - is $template.generate( :flag(False) ).render('html', - :doctype(Hitomi::DocType::HTML5)), - ' - - -', 'false if statement works'; -} diff --git a/t/hitomi/04-for.t b/t/hitomi/04-for.t deleted file mode 100644 index 0c8bb4f..0000000 --- a/t/hitomi/04-for.t +++ /dev/null @@ -1,38 +0,0 @@ -use v6; -use Test; -use Hitomi; - -plan 2; - -todo('Hitomi::Stream.render not implemented yet', 2); -{ - my Hitomi::MarkupTemplate $template .= new(' -

$_

- -'); - is $template.generate( '@list' => ).render('html', - :doctype(Hitomi::DocType::HTML5)), - ' - -

foo

-

bar

-

baz

- -', 'for loop with loop variable $_ works'; -} - -{ - my Hitomi::MarkupTemplate $template .= new(' -

$item

- -'); - is $template.generate( '@list' => ).render('html', - :doctype(Hitomi::DocType::HTML5)), - ' - -

foo

-

bar

-

baz

- -', 'for loop with custom loop variable works'; -} diff --git a/t/hitomi/05-input.t b/t/hitomi/05-input.t deleted file mode 100644 index 281ef32..0000000 --- a/t/hitomi/05-input.t +++ /dev/null @@ -1,308 +0,0 @@ -use v6; - -# Copyright (C) 2006 Edgewall Software -# All rights reserved. -# -# This software is licensed as described in the file licences/genshi/COPYING, -# which you should have received as part of this distribution. The terms -# are also available at http://genshi.edgewall.org/wiki/License. - -use Test; -plan 80; - -use Hitomi::Stream; -use Hitomi::XMLParser; -use Hitomi::HTMLParser; -use Hitomi::Attrs; -use Hitomi::Input; - -constant XMLParser = Hitomi::XMLParser; -constant HTMLParser = Hitomi::HTMLParser; -constant Attrs = Hitomi::Attrs; - -{ # test_text_node_pos_single_line - my $text = 'foo bar'; - my @events = (XMLParser.new($text)).llist; - my ($kind, $data, $pos) = @events[1]; - is Hitomi::StreamEventKind::text, $kind, 'got a text event'; - is 'foo bar', $data, 'the text is "foo bar"'; - is [Nil, 1, 6], $pos, '...on position 6 on line 1'; -} - -{ # test_text_node_pos_multi_line - my $text = 'foo -bar'; - my @events = (XMLParser.new($text)).llist; - my ($kind, $data, $pos) = @events[1]; - is Hitomi::StreamEventKind::text, $kind, 'got a text event'; - is "foo\nbar", $data, 'the text is "foo\nbar"'; - is [Nil, 1, 6], $pos, '...on position 6 on line 1'; - # Genshi differs here due to Expat, see the explanation on - # http://genshi.edgewall.org/browser/trunk/genshi/input.py#L179 -} - -{ # test_element_attribute_order - my $text = ''; - my @events = (XMLParser.new($text)).llist; - my ($kind, $data, $pos) = @events[0]; - is Hitomi::StreamEventKind::start, $kind, 'got a start event'; - my ($tag, $attrib) = @($data); - is 'elem', $tag, 'the tag has name "elem"'; - is 'title' => 'baz', $attrib[0], q[first attr is 'title="baz"']; - is 'id' => 'foo', $attrib[1], q[second attr is 'id="foo"']; - is 'class' => 'bar', $attrib[2], q[third attr is 'class="bar"']; -} - -{ # test_unicode_input - my $text = "
\c[2013]
"; - my @events = (XMLParser.new($text)).llist; - my ($kind, $data, $pos) = @events[1]; - is Hitomi::StreamEventKind::text, $kind, 'got a text event'; - is "\c[2013]", $data, 'the character survived'; -} - -skip(1); -# commented out: no Buf yet in Rakudo -##{ # test_latin1_encoded -## my $text = "
\x[f6]
".encode('iso-8859-1'); -## my @events = (XMLParser.new($text, :encoding)).llist; -## my ($kind, $data, $pos) = @events[1]; -## is Hitomi::StreamEventKind::text, $kind, 'got a text event'; -## is "\x[f6]", $data, 'the character survived'; -##} - -skip(1); -# commented out: no Buf yet in Rakudo -##{ # test_latin1_encoded_xmldecl -## my $text = qq[ -##
\x[f6]
-## ].encode'iso-8859-1'); -## my @events = (XMLParser.new($text, :encoding)).llist; -## my ($kind, $data, $pos) = @events[2]; -## is Hitomi::StreamEventKind::text, $kind, 'got a text event'; -## is "\x[f6]", $data, 'the character survived'; -##} - -skip(1); -# skip: XMLParser dies on this one for some reason -##{ # test_html_entity_with_dtd -## my $text = q[ -##  ]; -## my @events = (XMLParser.new($text)).llist; -## my ($kind, $data, $pos) = @events[2]; -## is Hitomi::StreamEventKind::text, $kind, 'got a text event'; -## is "\x[a0]", $data, 'the entity was turned into a character'; -##} - -{ # test_html_entity_without_dtd - my $text = ' '; - my @events = (XMLParser.new($text)).llist; - my ($kind, $data, $pos) = @events[1]; - is Hitomi::StreamEventKind::text, $kind, 'got a text event'; - is "\x[a0]", $data, 'the entity was turned into a character'; -} - -{ # test_html_entity_in_attribute - my $text = '

'; - my @events = (XMLParser.new($text)).llist; - my ($kind, $data, $pos) = @events[0]; - is Hitomi::StreamEventKind::start, $kind, 'got a start event'; - $data //= [*, {}]; - is "\x[a0]", $data[1].hash, 'the entity was turned into a character'; - $kind, $data, $pos = @events[1]; - is Hitomi::StreamEventKind::end, $kind, 'got an end event'; -} - -{ # test_undefined_entity_with_dtd - my $text = q[<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" - "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> - <html>&junk;</html>]; - my $survived = False; - try { - XMLParser.new($text).llist; - $survived = True; - } - ok !$survived, 'got a parse error'; -} - -{ # test_undefined_entity_without_dtd - my $text = '<html>&junk;</html>'; - my $survived = False; - try { - XMLParser.new($text).llist; - $survived = True; - } - ok !$survived, 'got a parse error'; -} - -todo('not implemented yet', 6); -{ # test_text_node_pos_single_line - my $text = '<elem>foo bar</elem>'; - my @events = (HTMLParser.new($text)).llist; - my ($kind, $data, $pos) = @events[1]; - is Hitomi::StreamEventKind::text, $kind, 'got a text event'; - is 'foo bar', $data, 'the text is "foo bar"'; - is [Nil, 1, 6], $pos, '...on position 6 on line 1'; -} - -{ # test_text_node_pos_multi_line - my $text = '<elem>foo -bar</elem>'; - my @events = (HTMLParser.new($text)).llist; - my ($kind, $data, $pos) = @events[1]; - is Hitomi::StreamEventKind::text, $kind, 'got a text event'; - is "foo\nbar", $data, 'the text is "foo bar"'; - is [Nil, 1, 6], $pos, '...on position 6 on line 1'; -} - -skip(1); -# commented out: no Buf yet in Rakudo -##{ # test_input_encoding_text -## my $text = "<div>\x[f6]</div>".encode('iso-8859-1'); -## my @events = (HTMLParser.new($text)).llist; -## my ($kind, $data, $pos) = @events[1]; -## is Hitomi::StreamEventKind::text, $kind, 'got a text event'; -## is "\x[f6]", $data, 'the character survived'; -##} - -skip(1); -# commented out: no Buf yet in Rakudo -##{ # test_input_encoding_attribute -## my $text = qq[<div title="\x[f6]"></div>].encode('iso-8859-1'); -## my @events = (HTMLParser.new($text)).llist; -## my ($kind, $data, $pos) = @events[0]; -## my ($tag, $attrib) = @($data); -## is Hitomi::StreamEventKind::text, $kind, 'got a text event'; -## is "\x[f6]", $attrib<title>, 'the character survived'; -##} - -todo('not implemented yet', 49); -{ # test_unicode_input - my $text = "<div>\c[2013]</div}"; - my @events = (HTMLParser.new($text)).llist; - my ($kind, $data, $pos) = @events[1]; - is Hitomi::StreamEventKind::text, $kind, 'got a text event'; - is "\c[2013]", $data, 'the character survived'; -} - -{ # test_html_entity_in_attribute - my $text = '<p title=" "></p>'; - my @events = (HTMLParser.new($text)).llist; - my ($kind, $data, $pos) = @events[0]; - is Hitomi::StreamEventKind::start, $kind, 'got a start event'; - $data //= [*, {}]; - is "\x[a0]", $data[1]<title>, 'the entity was turned into a character'; - $kind, $data, $pos = @events[1]; - is Hitomi::StreamEventKind::end, $kind, 'got an end event'; -} - -{ # test_html_entity_in_text - my $text = '<p> </p>'; - my @events = (HTMLParser.new($text)).llist; - my ($kind, $data, $pos) = @events[1]; - is Hitomi::StreamEventKind::text, $kind, 'got a text event'; - is "\x[a0]", $data, 'the entity was turned into a character'; -} - -{ # test_processing_instruction - my $text = '<?php echo "Foobar" ?>'; - my @events = (HTMLParser.new($text)).llist; - my ($kind, $td, $pos) = @events[0]; - my ($target, $data) = $td; - is Hitomi::StreamEventKind::pi, $kind, 'got a pi event'; - is 'php', $target, 'the target is "php"'; - is 'echo "Foobar"', $data, q[the data is 'echo "Foobar"']; -} - -{ # test_xmldecl - my $text = '<?xml version="1.0" ?><root />'; - my @events = (HTMLParser.new($text)).llist; - my ($kind, $data, $pos) = @events[0]; - my ($version, $encoding, $standalone) = $data; - is Hitomi::StreamEventKind::xml-decl, $kind, 'got an xml-decl event'; - is '1.0', $version, 'the version is 1.0'; - ok !defined $encoding, 'no encoding'; - is -1, $standalone, 'not standalone'; -} - -{ # test_xmldecl_encoding - my $text = '<?xml version="1.0" encoding="utf-8" ?><root />'; - my @events = (HTMLParser.new($text)).llist; - my ($kind, $data, $pos) = @events[0]; - my ($version, $encoding, $standalone) = $data; - is Hitomi::StreamEventKind::xml-decl, $kind, 'got an xml-decl event'; - is '1.0', $version, 'the version is 1.0'; - is 'utf-8', $encoding, 'the encoding is "utf-8"'; - is -1, $standalone, 'not standalone'; -} - -{ # test_xmldecl_standalone - my $text = '<?xml version="1.0" standalone="yes" ?><root />'; - my @events = (HTMLParser.new($text)).llist; - my ($kind, $data, $pos) = @events[0]; - my ($version, $encoding, $standalone) = $data; - is Hitomi::StreamEventKind::xml-decl, $kind, 'got an xml-decl event'; - is '1.0', $version, 'the version is 1.0'; - ok !defined $encoding, 'no encoding'; - is 1, $standalone, 'standalone'; -} - -{ # test_processing_instruction_trailing_qmark - my $text = '<?php echo "Foobar" ??>'; - my @events = (HTMLParser.new($text)).llist; - my ($kind, $dt, $pos) = @events[0]; - my ($target, $data) = $dt; - is Hitomi::StreamEventKind::pi, $kind, 'got a pi event'; - is 'php', $target, 'the target is "php"'; - is 'echo "Foobar" ?', $data, 'the data has one final "?"'; -} - -{ # test_out_of_order_tags - my $text = '<span><b>Foobar</span></b>'; - my @events = (HTMLParser.new($text)).llist; - is 5, +@events, 'got 5 events'; - @events ||= [] xx 5; - is [Hitomi::StreamEventKind::start, ['span', []]], @events[0][0,1], 'o1[1]'; - is [Hitomi::StreamEventKind::start, ['b', []]], @events[1][0,1], 'o1[2]'; - is [Hitomi::StreamEventKind::text, ['Foobar' ]], @events[2][0,1], 'o1[3]'; - is [Hitomi::StreamEventKind::end, ['b', ]], @events[3][0,1], 'o1[4]'; - is [Hitomi::StreamEventKind::end, ['span', ]], @events[4][0,1], 'o1[5]'; -} - -{ # test_out_of_order_tags2 - my $text = '<span class="baz"><b><i>Foobar</span></b></i>'; - my @events = (HTMLParser.new($text)).llist; - is 7, +@events, 'got 7 events'; - @events ||= [] xx 7; - is [Hitomi::StreamEventKind::start, ['span', Attrs.new(:class<baz>)]], - @events[0][0,1], 'o2[1]'; - is [Hitomi::StreamEventKind::start, ['b', []]], @events[1][0,1], 'o2[2]'; - is [Hitomi::StreamEventKind::start, ['i', []]], @events[2][0,1], 'o2[3]'; - is [Hitomi::StreamEventKind::text, ['Foobar' ]], @events[3][0,1], 'o2[4]'; - is [Hitomi::StreamEventKind::end, ['i', ]], @events[4][0,1], 'o2[5]'; - is [Hitomi::StreamEventKind::end, ['b', ]], @events[5][0,1], 'o2[6]'; - is [Hitomi::StreamEventKind::end, ['span', ]], @events[6][0,1], 'o2[7]'; -} - -{ # test_out_of_order_tags3 - my $text = '<span><b>Foobar</i>'; - my @events = (HTMLParser.new($text)).llist; - is 5, +@events, 'got 5 events'; - @events ||= [] xx 5; - is [Hitomi::StreamEventKind::start, ['span', []]], @events[0][0,1], 'o3[1]'; - is [Hitomi::StreamEventKind::start, ['b', []]], @events[1][0,1], 'o3[2]'; - is [Hitomi::StreamEventKind::text, ['Foobar' ]], @events[2][0,1], 'o3[3]'; - is [Hitomi::StreamEventKind::end, ['b', ]], @events[3][0,1], 'o3[4]'; - is [Hitomi::StreamEventKind::end, ['span', ]], @events[4][0,1], 'o3[5]'; -} - -{ # test_hex_charref - my $text = '<span>'</span>'; - my @events = (HTMLParser.new($text)).llist; - is 3, +@events, 'got 3 events'; - @events ||= [] xx 3; - is [Hitomi::StreamEventKind::start, ['span', []]], @events[0][0,1], 'hc[1]'; - is [Hitomi::StreamEventKind::text, ["'" ]], @events[1][0,1], 'hc[2]'; - is [Hitomi::StreamEventKind::end, ['span' ]], @events[2][0,1], 'hc[3]'; -} diff --git a/t/hitomi/06-markup.t b/t/hitomi/06-markup.t deleted file mode 100644 index 027e887..0000000 --- a/t/hitomi/06-markup.t +++ /dev/null @@ -1,252 +0,0 @@ -use v6; - -# Copyright (C) 2006 Edgewall Software -# All rights reserved. -# -# This software is licensed as described in the file licences/genshi/COPYING, -# which you should have received as part of this distribution. The terms -# are also available at http://genshi.edgewall.org/wiki/License. - -use Test; -plan 22; - -use Hitomi::Stream; -use Hitomi::Markup; -use Hitomi::Input; - -constant Stream = Hitomi::Stream; -constant MarkupTemplate - = Hitomi::MarkupTemplate; -constant Markup = Hitomi::Markup; - -## MarkupTemplateTestCase - Tests for markup template processing. - -{ # test_parse_string - my $string = '<root> ${$var} $var</root>'; - my $tmpl = MarkupTemplate.new($string); - is '<root> 42 42</root>', - ~$tmpl.generate(:var(42)), - 'markup from a string'; -} - -skip(1); -# skip: unknown error in MarkupTemplate.new($stream) -##{ # test_parse_stream -## my Stream $stream = XML('<root> ${$var} $var</root>'); -## my $tmpl = MarkupTemplate.new($stream); -## is '<root> 42 42</root>', ~$tmpl.generate(:var(42)), 'markup from a stream'; -##} - -skip(1); -# skip: unknown error in MarkupTemplate.new($stream) -##{ # test_pickle -## # Not sure how we will want to do this. -## my Stream $stream = XML('<root>$var</root>'); -## my $tmpl = MarkupTemplate.new($stream); -## my $buf = $tmpl.perl; -## my $unpickled = eval($buf); -## is '<root>42</root>', ~$unpickled.?generate(:var(42)), -## 'template survives pickling'; -##} - -{ # test_interpolate_mixed3 - my $tmpl = MarkupTemplate.new('<root> ${$var} $var</root>'); - is '<root> 42 42</root>', ~$tmpl.generate(:var(42)), 'mixed interpolation'; -} - -todo('not implemented yet', 2); -{ # test_interpolate_leading_trailing_space - my $tmpl = MarkupTemplate.new('<root>${ $foo }</root>'); - is '<root>bar</root>', ~$tmpl.generate(:foo<bar>), 'leading/trailing space'; -} - -{ # test_interpolate_multiline - my $tmpl = MarkupTemplate.new(q[<root>${( - bar => 'baz' - ).hash{$foo}}</root>]); - is '<root>baz</root>', ~$tmpl.generate(:foo<bar>), 'interpolate multiline'; -} - -skip(1); -##{ # test_interpolate_non_string_attrs -## my $tmpl = MarkupTemplate.new('<root attr="${1}"/>'); -## is '<root attr="1"/>', ~$tmpl.generate(), 'interpolate non-string attrs'; -##} - -todo('not implemented', 1); -{ # test_interpolate_list_result - my $tmpl = MarkupTemplate.new('<root>@foo</root>'); - is '<root>buzz</root>', ~$tmpl.generate('@foo' => ['buzz']), - 'interpolate lists'; -} - -skip(1); -##{ # test_empty_attr -## my $tmpl = MarkupTemplate.new('<root attr=""/>'); -## is '<root attr=""/>', ~$tmpl.generate(), 'empty attribute'; -##} - -skip(1); -##{ # test_empty_attr_interpolated -## my $tmpl = MarkupTemplate.new('<root attr="$attr"/>'); -## is '<root attr=""/>', ~$tmpl.generate(:attr<>), 'empty attr, interpolated'; -##} - -todo('not implemented', 3); -{ # test_bad_directive_error - my $xml - = '<p xmlns:pl="http://github.com/masak/hitomi" pl:do="nothing" />'; - my $died = True; - try { - my $tmpl = MarkupTemplate.new($xml, :filename<test.html>); - $died = False; - } - # RAKUDO: When we have CATCH, we will want to check the error type here - ok $died, 'error on bad directive'; - # self.assertEqual('test.html', e.filename) - # self.assertEqual(1, e.lineno) -} - -{ # test_directive_value_syntax_error - my $xml = q[<p xmlns:pl="http://github.com/masak/hitomi" pl:if="bar'" />]; - my $died = True; - try { - my $tmpl = MarkupTemplate.new($xml, :filename<test.html>).generate(); - $died = False; - } - # RAKUDO: When we have CATCH, we will want to check the error type here - ok $died, 'error on bad directive'; - # self.assertEqual('test.html', e.filename) - # self.assertEqual(1, e.lineno) -} - -{ # test_expression_syntax_error - my $xml = q[<p> - Foo <em>${bar"}</em> - </p>]; - my $died = True; - try { - my $tmpl = MarkupTemplate.new($xml, :filename<test.html>); - $died = False; - } - # RAKUDO: When we have CATCH, we will want to check the error type here - ok $died, 'template syntax error'; - # self.assertEqual('test.html', e.filename) - # self.assertEqual(2, e.lineno) -} - -{ # test_expression_syntax_error_multi_line - my $xml = q[<p><em></em> - - ${bar"} - - </p>]; - my $died = True; - try { - my $tmpl = MarkupTemplate.new($xml, :filename<test.html>); - $died = False; - } - # RAKUDO: When we have CATCH, we will want to check the error type here - ok $died, 'template syntax error'; - # self.assertEqual('test.html', e.filename) - # self.assertEqual(3, e.lineno) -} - -skip(1); -##{ # test_markup_noescape -## # Verify that outputting context data that is a `Markup` instance is not -## # escaped. -## my $tmpl = MarkupTemplate.new( -## '<div xmlns:pl="http://github.com/masak/hitomi"> -## $myvar -## </div>'); -## is '<div> -## <b>foo</b> -## </div>', ~$tmpl.generate(:myvar(Markup.new('<b>foo</b>'))), -## 'no escaping of Markup variables'; -##} - -skip(1); -##{ # test_text_noescape_quotes -## # Verify that outputting context data in text nodes doesn't escape -## # quotes. -## my $tmpl = MarkupTemplate.new( -## '<div xmlns:pl="http://github.com/masak/hitomi"> -## $myvar -## </div>'); -## is '<div> -## "foo" -## </div>', ~$tmpl.generate(:myvar<"foo">), -## 'no escaping of quotes in text'; -##} - -skip(1); -##{ # test_attr_escape_quotes -## # Verify that outputting context data in attribtes escapes quotes. -## my $tmpl = MarkupTemplate.new( -## '<div xmlns:pl="http://github.com/masak/hitomi"> -## <elem class="$myvar"/> -## </div>'); -## is '<div> -## <elem class=""foo""/> -## </div>', ~$tmpl.generate(:myvar<"foo">), -## 'escaping of quotes in attrs'; -##} - -skip(1); -##{ # test_directive_element -## my $tmpl = MarkupTemplate.new( -## '<div xmlns:pl="http://github.com/masak/hitomi"> -## <pl:if test="myvar">bar</pl:if> -## </div>'); -## is '<div> -## bar -## </div>', ~$tmpl.generate(:myvar<"foo">), 'directive'; -##} - -skip(1); -##{ # test_normal_comment -## my $tmpl = MarkupTemplate.new( -## '<div xmlns:pl="http://github.com/masak/hitomi"> -## <!-- foo bar --> -## </div>'); -## is '<div> -## <!-- foo bar --> -## </div>', ~$tmpl.generate(), 'normal comment'; -##} - -skip(1); -##{ # test_template_comment -## my $tmpl = MarkupTemplate.new( -## '<div xmlns:pl="http://github.com/masak/hitomi"> -## <!-- !foo --> -## <!--!bar--> -## </div>'); -## is '<div> -## </div>', ~$tmpl.generate(), 'template comment'; -##} - -skip(1); -##{ # test_parse_with_same_namespace_nested -## my $tmpl = MarkupTemplate.new( -## '<div xmlns:pl="http://github.com/masak/hitomi"> -## <span xmlns:pl="http://github.com/masak/hitomi"> -## </span> -## </div>'); -## is '<div> -## <span> -## </span> -## </div>', ~$tmpl.generate(), 'nested namespace'; -##} - -skip(1); -##{ # test_latin1_encoded_with_xmldecl -## my $tmpl = MarkupTemplate.new( -## qq[<?xml version="1.0" encoding="iso-8859-1" ?> -## <div xmlns:pl="http://github.com/masak/hitomi"> -## \xf6 -## </div>].encode('UTF-8').decode('iso-8859-1'), :encoding<iso-8859-1>); -## is qq[<?xml version="1.0" encoding="iso-8859-1"?>\n<div> -## \xf6 -## </div>], ~$tmpl.generate(), 'latin1 encoded with xmldecl'; -##}