Merge pull request #784 from fglock/fix/module-loaded-less-pragma

Fix Module::Loaded by adding less pragma

Author: fglock

src/main/perl/lib/less.pm

@@ -0,0 +1,76 @@
+package less;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.03';
+
+sub _pack_tags {
+    return join ' ', @_;
+}
+
+sub _unpack_tags {
+    return grep { defined and length }
+        map { split ' ' }
+        grep { defined } @_;
+}
+
+sub stash_name {
+    return $_[0];
+}
+
+sub of {
+    my $class = shift;
+
+    return unless defined wantarray;
+
+    my $hinthash = (caller 0)[10] || {};
+    my %tags;
+    @tags{ _unpack_tags($hinthash->{ $class->stash_name }) } = ();
+
+    if (@_) {
+        exists $tags{$_} and return 1 for @_;
+        return;
+    }
+
+    return keys %tags;
+}
+
+sub import {
+    my $class = shift;
+    my $stash = $class->stash_name;
+
+    @_ = 'please' if !@_;
+
+    my %tags;
+    @tags{ _unpack_tags(@_, $^H{$stash}) } = ();
+    $^H{$stash} = _pack_tags(keys %tags);
+
+    return;
+}
+
+sub unimport {
+    my $class = shift;
+    my $stash = $class->stash_name;
+
+    if (@_) {
+        my %tags;
+        @tags{ _unpack_tags($^H{$stash}) } = ();
+        delete @tags{ _unpack_tags(@_) };
+
+        my $new = _pack_tags(keys %tags);
+        if (length $new) {
+            $^H{$stash} = $new;
+        }
+        else {
+            delete $^H{$stash};
+        }
+    }
+    else {
+        delete $^H{$stash};
+    }
+
+    return;
+}
+
+1;

src/test/resources/unit/less_pragma.t

@@ -0,0 +1,30 @@
+use strict;
+use warnings;
+use Test::More;
+
+ok(!less->of, 'less has no active tags by default');
+
+{
+    use less;
+    ok(less->of('please'), 'use less defaults to please');
+    is_deeply([sort less->of], ['please'], 'less->of lists active default tag');
+}
+
+ok(!less->of('please'), 'less hint is lexical');
+
+{
+    use less qw(memory CPU);
+    ok(less->of('memory'), 'less sees memory tag');
+    ok(less->of('CPU'), 'less sees CPU tag');
+    ok(less->of('CPU', 'disk'), 'less checks any requested tag');
+
+    {
+        no less 'CPU';
+        ok(less->of('memory'), 'no less removes only named tag');
+        ok(!less->of('CPU'), 'CPU tag removed');
+    }
+
+    ok(less->of('CPU'), 'outer less tags are restored');
+}
+
+done_testing;