WIP

perlpunk · Dec 29, 2023 · bd30a75 · bd30a75
1 parent bfa018e
commit bd30a75
Show file tree

Hide file tree

Showing 5 changed files with 64 additions and 12 deletions.
diff --git a/.github/workflows/linux.yaml b/.github/workflows/linux.yaml
@@ -56,6 +56,7 @@ jobs:
       run: >
         cpanm --quiet --notest
         Module::Load Test::Warn Test::More JSON::PP boolean
+        YAML::PP::LibYAML
     - name: Run Tests
       run: prove -lr t
 

diff --git a/lib/YAML/PP/Loader.pm b/lib/YAML/PP/Loader.pm
@@ -81,12 +81,19 @@ sub load_string {
     my ($self, $yaml) = @_;
     my $utf8 = $self->{utf8};
     my $p = $self->parser;
-    $self->parser->set_reader(YAML::PP::Reader->new(
-        input => $yaml,
-        utf8_in => $self->{utf8},
-        utf8_out => 0,
-    ));
-    $self->load();
+    if ($self->parser->can('new_reader')) {
+        $self->parser->new_reader('YAML::PP::Reader' =>
+            input => $yaml,
+            utf8_in => $self->{utf8},
+        );
+        $self->load();
+    }
+    else {
+        $self->parser->set_reader(YAML::PP::Reader->new(
+            input => $yaml,
+            utf8_in => $self->{utf8},
+        ));
+    }
 }
 
 sub load_file {

diff --git a/lib/YAML/PP/Parser.pm b/lib/YAML/PP/Parser.pm
@@ -70,6 +70,15 @@ sub set_reader {
     my ($self, $reader) = @_;
     $self->lexer->set_reader($reader);
 }
+sub new_reader {
+    my ($self, $class, %args) = @_;
+    my $reader = $class->new(
+        input => $args{input},
+        utf8_in => $args{utf8_in},
+        utf8_out => 0,
+    );
+    $self->lexer->set_reader($reader);
+}
 sub lexer { return $_[0]->{lexer} }
 sub callback { return $_[0]->{callback} }
 sub set_callback { $_[0]->{callback} = $_[1] }

diff --git a/lib/YAML/PP/Reader.pm b/lib/YAML/PP/Reader.pm
@@ -15,7 +15,6 @@ sub new {
     my $utf8_in = delete $args{utf8_in};
     my $utf8_out = delete $args{utf8_out};
     $utf8_in = 0 unless defined $utf8_in;
-    $utf8_out = 0 unless defined $utf8_out;
     if (keys %args) {
         die "Unexpected arguments: " . join ', ', sort keys %args;
     }
@@ -30,14 +29,14 @@ sub new {
 
 sub _prepare_input {
     my ($self) = @_;
+    return unless defined $self->{utf8_out};
+#    warn __PACKAGE__.':'.__LINE__.": ???????????????????? $self->{utf8_in} $self->{utf8_out}\n";
     if ($self->{utf8_in} and $self->{utf8_out} == 0) {
-        warn __PACKAGE__.':'.__LINE__.": !!!!!!!!! DECODE '$self->{input}'\n";
-        warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$self], ['self']);
+#        warn __PACKAGE__.':'.__LINE__.": !!!!!!!!! DECODE '$self->{input}'\n";
         $self->{input} = decode 'UTF-8', $self->{input}, Encode::FB_CROAK;
     }
     elsif ($self->{utf8_in} == 0 and $self->{utf8_out}) {
-        warn __PACKAGE__.':'.__LINE__.": !!!!!!!!! ENCODE '$self->{input}'\n";
-        warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$self], ['self']);
+#        warn __PACKAGE__.':'.__LINE__.": !!!!!!!!! ENCODE '$self->{input}'\n";
         $self->{input} = encode 'UTF-8', $self->{input}, Encode::FB_CROAK;
     }
 }

diff --git a/t/58.utf8.t b/t/58.utf8.t
@@ -46,7 +46,7 @@ subtest 'load unicode' => sub {
     is $data->[0], $bear_perl, 'load decoded with default loader';
 
     $data = $p_default->load_string($utf8);
-    is $data->[0], 'bär', 'load utf8 with default loader';
+    is $data->[0], $bear_utf8, 'load utf8 with default loader';
 };
 
 subtest 'dump unicode' => sub {
@@ -67,4 +67,40 @@ subtest 'dump unicode' => sub {
     $yaml, $bear_utf8, 'dump utf8 data with perl dumper -> utf8';
 };
 
+my $pplib = eval "use YAML::PP::LibYAML; 1";
+
+subtest 'YAML::PP::LibYAML' => sub {
+    plan(skip_all => 'YAML::PP::LibYAML not installed') unless $pplib;
+    diag "YAML::PP::LibYAML " . YAML::PP::LibYAML->VERSION;
+    my $p_utf8 = YAML::PP::LibYAML->new(
+        header => 0,
+        utf8 => 1,
+    );
+    my $p_perl = YAML::PP::LibYAML->new(
+        header => 0,
+        utf8 => 0,
+    );
+    my $p_default = YAML::PP::LibYAML->new(header => 0);
+    subtest 'load unicode' => sub {
+        my $data = $p_utf8->load_string($utf8);
+        is $data->[0], $bear_perl, 'load utf8';
+
+        $data = $p_utf8->load_string($perl);
+        is $data->[0], $bear_perl, 'load decoded with utf8 loader passes (libyaml XS binding can work with both)';
+
+        $data = $p_perl->load_string($perl);
+        is $data->[0], $bear_perl, 'load decoded with perl loader';
+
+        $data = $p_perl->load_string($utf8);
+        is $data->[0], $bear_perl, 'load utf8 with perl loader';
+
+        $data = $p_default->load_string($perl);
+        is $data->[0], $bear_perl, 'load decoded with default loader';
+
+        $data = $p_default->load_string($utf8);
+        is $data->[0], $bear_perl, 'load utf8 with default loader';
+    };
+};
+
+
 done_testing;