Replace underscores with hyphens in Perl Catalyst URLs - perl

We're looking at options for converting CamelCase to camel-case and underscores to hyphens and hoping someone can offer some strong examples. (Using hyphens for SEO reasons).
Specifically:
Working on an MMORPG in Catalyst and getting tired of having to write things like this:
sub travel_to ( $self, $c, $star ) : Path('travel-to') Args(1) { ... }
Or this:
package Veure::Controller::Area::StorageLocker {
....
sub index ( $self, $c ) : Path('/area/storage-locker') { ... }
}
Update: Because there's some confusion, I meant that we'd much prefer to have devs write this:
# getting rid of Args() would be nice, but sigs don't have introspection
sub travel_to ( $self, $c, $star ) : Args(1) { ... }
Or this:
package Veure::Controller::Area::StorageLocker {
....
sub index ( $self, $c ) { ... }
}
This is important because for an SEO standpoint, underscores instead of hyphens can dramatically improve your SEO. By having to do extra grunt work to always force hyphens, developers are forgetting to do this and we keep wasting money going back and having to rewrite code where this caveat was forgotten. This is the sort of thing which we should be able to do automatically.

I did a bit of digging in the Catalyst sources.
Cammel case controller names
You can modify class2prefix in Catalyst::Utils to change how the controller names translate to the namespace.
Here is a very quick hack that demonstrates what is going on with a fresh MyApp created with catalyst.pl. I borrowed Borodin's suggestion to implement it.
package MyApp::Controller::FooBar;
use Moose;
use namespace::autoclean;
BEGIN { extends 'Catalyst::Controller'; }
{
require Class::Method::Modifiers;
require String::CamelCase;
Class::Method::Modifiers::around(
'Catalyst::Utils::class2prefix' => sub {
my $orig = shift;
# I borrowed most of this from the original function ...
my $class = shift || '';
my $prefix = shift || 0;
if ( $class =~ /^.+?::([MVC]|Model|View|Controller)::(.+)$/ ) {
$prefix = $2;
$prefix =~ s{::}{/}g;
# ... and this from https://stackoverflow.com/a/37968830/1331451
$prefix = String::CamelCase::decamelize($prefix) =~ tr/_/-/r;
}
return $prefix;
}
);
}
sub index :Path :Args(0) {
my ( $self, $c ) = #_;
$c->response->body('Matched MyApp::Controller::FooBar in FooBar.');
}
1;
I tested this briefly, but cannot guarantee it's not going to break anything else. I believe if it's put into a better place and done in a more appropriate way it could be a viable option.
Underscores in actions
This one looks trickier. My best bet is to fiddle with Catalyst::DispatchType::Path in some way, or create something that installs an ActionClass that modifies it. It's basically replacing the _ with a -. That thing could be built around gather_default_action_roles in Catalyst::Controller (maybe as a subclass) to add that one to all actions. This is highly speculative.

CPAN has the String::CamelCase module, which offers a decamelize function, after which you will need to convert underscores to hyphens using tr/_/-/
I hope this short example helps to answer your question
use strict;
use warnings 'all';
use v.14.1;
use String::CamelCase 'decamelize';
for my $s ( 'travel_to', 'Veure::Controller::Area::StorageLocker' ) {
(my $ss = $s) =~ s|^[\w:]*::Controller(?=::)||;
$ss =~ s|::|/|g;
$ss = decamelize($ss) =~ tr/_/-/r;
say $ss;
}
output
travel-to
/area/storage-locker

Related

Should a subroutine always return explicitly?

If perlcritic says "having no returns in a sub is wrong", what is the alternative if they really aren't needed?
I've developed two apparently bad habits:
I explicitly assign variables to the '$main::' namespace.
I then play with those variables in subs.
For example, I might do..
#!/usr/bin/perl
use strict;
use warnings;
#main::array = (1,4,2,6,1,8,5,5,2);
&sort_array;
&push_array;
&pop_array;
sub sort_array{
#main::array = sort #main::array;
for (#main::array){
print "$_\n";
}
}
sub push_array{
for ( 1 .. 9 ){
push #main::array, $_;
}
}
sub pop_array {
for ( 1 .. 3 ){
pop #main::array;
}
}
I don't do this all the time. But in the above, it makes sense, because I can segregate the operations, not have to worry about passing values back and forth and it generally looks tidy to me.
But as I said, perl critic says its wrong - because there's no return..
So, is anyone able to interpret what I'm trying to do and suggest a better way of approaching this style of coding in perl? eg. am I sort of doing OOP?
In short - yes, you're basically doing OO, but in a way that's going to confuse everyone.
The danger of doing subs like that is that you're acting at a distance. It's a bad coding style to have to look somewhere else entirely for what might be breaking your code.
This is generally why 'globals' are to be avoided wherever possible.
For a short script, it doesn't matter too much.
Regarding return values - Perl returns the result of the last expression by default. (See: return)
(In the absence of an explicit return, a subroutine, eval, or do FILE automatically returns the value of the last expression evaluated.)
The reason Perl critic flags it is:
Require all subroutines to terminate explicitly with one of the following: return, carp, croak, die, exec, exit, goto, or throw.
Subroutines without explicit return statements at their ends can be confusing. It can be challenging to deduce what the return value will be.
Furthermore, if the programmer did not mean for there to be a significant return value, and omits a return statement, some of the subroutine's inner data can leak to the outside.
Perlcritic isn't always right though - if there's good reason for doing what you're doing, then turn it off. Just as long as you've thought about it and are aware of the risks an consequences.
Personally I think it's better style to explicitly return something, even if it is just return;.
Anyway, redrafting your code in a (crude) OO fashion:
#!/usr/bin/perl
use strict;
use warnings;
package MyArray;
my $default_array = [ 1,4,2,6,1,8,5,5,2 ];
sub new {
my ( $class ) = #_;
my $self = {};
$self -> {myarray} = $default_array;
bless ( $self, $class );
return $self;
}
sub get_array {
my ( $self ) = #_;
return ( $self -> {myarray} );
}
sub sort_array{
my ( $self ) = #_;
#{ $self -> {myarray} } = sort ( #{ $self -> {myarray} } );
for ( #{ $self -> {myarray} } ) {
print $_,"\n";
}
return 1;
}
sub push_array{
my ( $self ) = #_;
for ( 1 .. 9 ){
push #{$self -> {myarray}}, $_;
}
return 1;
}
sub pop_array {
my ( $self ) = #_;
for ( 1 .. 3 ){
pop #{$self -> {myarray}};
}
return 1;
}
1;
And then call it with:
#!/usr/bin/perl
use strict;
use warnings;
use MyArray;
my $array = MyArray -> new();
print "Started:\n";
print join (",", #{ $array -> get_array()} ),"\n";
print "Reshuffling:\n";
$array -> sort_array();
$array -> push_array();
$array -> pop_array();
print "Finished:\n";
print join (",", #{ $array -> get_array()} ),"\n";
It can probably be tidied up a bit, but hopefully this illustrates - within your object, you've got an internal 'array' which you then 'do stuff with' by making your calls.
Result is much the same (I think I've replicated the logic, but don't trust that entirely!) but you have a self contained thing going on.
If the function doesn't mean to return anything, there's no need to use return!
No, you don't use any aspects of OO (encapsulation, polymorphism, etc). What you are doing is called procedural programming. Nothing wrong with that. All my work for nuclear power plants was written in that style.
The problem is using #main::array, and I'm not talking about the fact that you could abbreviate that to #::array. Fully-qualified names escape strict checks, so they are far, far more error-prone. Mistyped var name won't get caught as easily, and it's easy to have two pieces of code collide by using the same variable name.
If you're just using one file, you can use my #array, but I presume you are using #main::array because you are accessing it from multiple files/modules. I suggest placing our #array in a module, and exporting it.
package MyData;
use Exporter qw( import );
our #EXPORT = qw( #array );
our #array;
1;
Having some kind of hint in the variable name (such as a prefix or suffix) indicating this is a variable used across many modules would be nice.
By the way, if you wanted do create an object, it would look like
package MyArray;
sub new {
my $class = shift;
my $self = bless({}, $class);
$self->{array} = [ #_ ];
return $self;
}
sub get_elements {
my ($self) = #_;
return #{ $self->{array} };
}
sub sort {
my ($self) = #_;
#{ $self->{array} } = sort #{ $self->{array} };
}
sub push {
my $self = shift;
push #{ $self->{array} }, #_;
}
sub pop {
my ($self, $n) = #_;
return splice(#{ $self->{array} }, 0, $n//1);
}
my $array = MyArray->new(1,4,2,6,1,8,5,5,2);
$array->sort;
print("$_\n") for $array->get_elements();
$array->push_array(1..9);
$array->pop_array(3);
I improved your interface a bit. (Sorting shouldn't print. Would be nice to push different things and to pop other than three elements.)

Implementing Feature Toggles in Perl5

i'd like to be able to create "ghost" packages and subs. I have a configuration (ini) file with entries like this:
[features]
sys.ext.latex = off
gui.super.duper.elastic = off
user.login.rsa = on
This file is parsed, and later developers can ask questions like:
if ( MyApp::Feature->enabled ( 'user.login.rsa' ) { ... }
(The whole idea is based on Martin Fowler's FeatureToggle http://martinfowler.com/bliki/FeatureToggle.html)
Using AUTOLOAD for catching calls in MyApp::Feature, and BEGIN block for parsing ini file we are able to provide this API:
if ( MyApp::Feature->user_login_rsa ) { ... }
The question is: Is it possible to create following API:
if ( MyApp::Feature::User::Login::RSA ) { ... }
having only MyApp::Feature?
Lower,upper case can be modified in the config file, that's not the issue here. And make it clear, implementation is decoupled from the configuration, there is no MyApp::Feature::User::Login::RSA and never will be. Implementation for this feature lies f.e. in MyApp::Humans.
I am aware that putting MyApp::Feature::Foo::Bar suggests there must be such Package. But developers know the convention that Feature package manages feature toggles and they would have no problems with that. I find the first example (using enabled( $string ) bit too complex to read
if ( package::package->method ( string ) )
the second one better:
if ( package::package->method )
the third would be even easier:
if ( package::package::package )
So, is it possible to simulate AUTOLOAD on the package level?
Greetings,
Rob.
So it sounds like you have a list of multi-word keys that you want to install into a namespace.
BEGIN {
my %states = ( # the values that should be transformed
on => sub () {1},
off => sub () {''},
);
sub install_config {
my ($package, $config) = #_;
for my $key (keys %$config) {
my #parts = map ucfirst, split /\./, $key;
my $name = join '::' => $package, #parts;
no strict 'refs';
*{$name} = $states{$$config{$key}} # use a tranformed value
|| sub () {$$config{$key}} # or the value itself
}
}
}
BEGIN {
my %config = qw(
sys.ext.latex off
gui.super.duper.elastic off
user.login.rsa on
some.other.config other_value
);
install_config 'MyApp::Feature' => \%config;
}
say MyApp::Feature::Sys::Ext::Latex ? 'ON' : 'OFF'; # OFF
say MyApp::Feature::Gui::Super::Duper::Elastic ? 'ON' : 'OFF'; # OFF
say MyApp::Feature::User::Login::Rsa ? 'ON' : 'OFF'; # ON
say MyApp::Feature::Some::Other::Config; # other_value
The constant subroutines installed here are will be inlined by perl when applicable.
You can make install_config a bit easier to use by putting it into a package's import function:
BEGIN {$INC{'Install/Config.pm'}++} # fool require
sub Install::Config::import {shift; goto &install_config}
use Install::Config 'MyApp::Feature' => {qw(
sys.ext.latex off
gui.super.duper.elastic off
user.login.rsa on
some.other.config other_value
)};

Perl: Syntactical Sugar for Latter Coderef Arguments?

Using sub prototypes, we can define our own subs that look like map or grep. That is, the first coderef argument has shorter syntax than a normal anonymous sub. For example:
sub thunked (&) { $_[0] }
my $val = thunked { 2 * 4 };
Works great here, since the first argument is the coderef. For latter arguments however, it simple won't parse properly.
I made a with sub designed to make writing GTK2 code cleaner. It's meant to look like this (untested since it's hypothetical code):
use 5.012;
use warnings;
use Gtk2 '-init';
sub with ($&) {
local $_ = $_[0];
$_[1]->();
$_;
}
for (Gtk2::Window->new('toplevel')) {
$_->set_title('Test Application');
$_->add(with Gtk2::VBox->new {
my $box = $_;
$box->add(Gtk2::Button->new("Button $_")) for (1..4);
});
$_->show_all;
}
Gtk2->main;
It doesn't work because with needs to take the block as a first argument for the nice syntax to work. Is there any way to pull it off?
The module Devel::Declare contains tools for extending Perl's syntax in a relatively safe way.
Using Devel::Declare you would create a hook on the with token, which will stop the parser when it reaches that word. From there, you have control over the parser and you can read ahead until you reach a { symbol. At that point, you have what you need to work with, so you rewrite it into valid Perl, and pass it back to the parser.
in the file With.pm:
package With;
use warnings;
use strict;
use Devel::Declare;
sub import {
my $caller = caller;
Devel::Declare->setup_for (
$caller => {with => {const => \&parser}}
);
no strict 'refs';
*{$caller.'::with'} = sub ($&) {
$_[1]() for $_[0];
$_[0]
}
}
our $prefix = '';
sub get {substr Devel::Declare::get_linestr, length $prefix}
sub set { Devel::Declare::set_linestr $prefix . $_[0]}
sub parser {
local $prefix = substr get, 0, length($_[0]) + $_[1];
my $with = strip_with();
strip_space();
set "scalar($with), sub " . get;
}
sub strip_space {
my $skip = Devel::Declare::toke_skipspace length $prefix;
set substr get, $skip;
}
sub strip_with {
strip_space;
my $with;
until (get =~ /^\{/) {
(my $line = get) =~ s/^([^{]+)//;
$with .= $1;
set $line;
strip_space;
}
$with =~ s/\s+/ /g;
$with
}
and to use it:
use With;
sub Window::add {say "window add: ", $_[1]->str}
sub Window::new {bless [] => 'Window'}
sub Box::new {bless [] => 'Box'}
sub Box::add {push #{$_[0]}, #_[1..$#_]}
sub Box::str {"Box(#{$_[0]})"}
sub Button::new {"Button($_[1])"}
with Window->new {
$_->add(with Box->new {
for my $num (1 .. 4) {
$_->add(Button->new($num))
}
})
};
Which prints:
window add: Box(Button(1) Button(2) Button(3) Button(4))
A completely different approach would be to skip the with keyword altogether and write a routine to generate constructor subroutines:
BEGIN {
for my $name (qw(VBox)) { # and any others you want
no strict 'refs';
*$name = sub (&#) {
use strict;
my $code = shift;
my $with = "Gtk2::$name"->new(#_);
$code->() for $with;
$with
}
}
}
and then your code could look like
for (Gtk2::Window->new('toplevel')) {
$_->set_title('Test Application');
$_->add(VBox {
my $box = $_;
$box->add(Gtk2::Button->new("Button $_")) for (1..4);
});
$_->show_all;
}
One way that you could deal with it is to add a fairly useless keyword:
sub perform(&) { $_[0] }
with GTK2::VBox->new, perform { ... }
where perform is really just a sugarier alternative to sub.
Another way is to write a Devel::Declare filter or a Syntax::Keyword:: plugin to implement your with, as long as you have some way to tell when you're done parsing the with argument and ready to start parsing the block — balanced parentheses would do (so would an opening curly brace, but then hashes become a problem). Then you could support something like
with (GTK2::VBox->new) { ... }
and let the filter rewrite it to something like
do {
local $_ = GTK2::VBox->new;
do {
...;
};
$_;
}
which, if it works, has the advantage of not actually creating a sub, and thus not interfering with #_, return, and a few other things. The two layers of do-age I think are necessary for being able to install an EndOfScope hook in the proper place.
The obvious disadvantages of this are that it's tricky, it's hairy, and it's a source filter (even if it's a tame one) which means there are problems you have to solve if you want any code using it to be debuggable at all.

what is the best way to hanlde optional url arguments in a Catalyst controller?

For example:
I know how to match www.domain.com/foo/21
sub foo : Path('/foo') Args(1) {
my ( $self, $c, $foo_id ) = #_;
# do stuff with foo
}
But how can I match www.domain.com/foo/21 OR www.domain.com/foo/21/bar/56 ?
sub foo : <?> {
my ( $self, $c, $foo_id, $bar_id ) = #_;
# do stuff with foo, and maybe do some things with bar if present
}
Thanks
Update:
Following Daxim's suggestion, I tried to use :Regex
sub foo : Regex('foo/(.+?)(?:/bar/(.+))?') {
my ( $self, $c ) = #_;
my ( $foo_id, $bar_id ) = #{ $c->req->captures };
}
But this doesn't seem to work; the url is matched, but $bar_id is always undef. If I remove the optional opperator from the end of the regex then it does capture $bar_id correctly, but then both foo and bar must be present to get a url match. I'm not sure if this is a perl regex issue, or a Catalyst issue. Any ideas?
Update:
As Daxim points out, its a regex issue. I can't see why the above regex doesn't work, but I did manage to find one that does:
sub foo : Regex('foo/([^/]+)(?:/bar/([^/]+))?') {
my ( $self, $c ) = #_;
my ( $foo_id, $bar_id ) = #{ $c->req->captures };
}
(I didn't use \d+ in the captures like Daxim did as my ids might not be numeric)
Thanks all for the help and suggestions, I learnt a lot about handling urls in Catalyst :D
The Args attribute doesn't have to be limited to a specific number of arguments. For instance, the following should work:
sub foo :Args() { # matches /foo, /foo/123, /foo/123/bar/456, /foo/123/bar/456/*
my($self, $c, $foo_id, %optional_params) = #_;
if($optional_params{bar}){
# ...
}
}
Keep in mind that all of the remaining URL segments after the path prefix and action name will be present in #remainder. Also, since you're not specifying how many arguments you need, Catalyst will allow a URL without any args to match this action. Validate your input accordingly!
UPDATED with :Chained example
The following (untested) catalyst actions would provide you with a little more strict action matching that you seem to be looking for. The downside is that you must rely on the stash to share data between all the actions.
sub foo :Chained('/') :PathPart :CaptureArgs(1) {
my($self, $c, $foo_id) = #_;
$c->stash->{foo_id} = $foo_id; # or whatever
}
sub foo_no_bar :Chained('foo') :Args(0) {
my($self, $c) = #_;
# matches on /foo/123 but not /foo/123/bar/456
my $foo_id = $c->stash->{foo_id};
}
sub bar :Chained('foo') :PathPart :Args(1) {
my($self, $c, $bar_id) = #_;
my $foo_id = $c->stash->{foo_id};
# matches on /foo/123/bar/456 but not /foo/123 or /foo/123/baz/456
}
See item Pattern-match (:Regex and :LocalRegex) in Catalyst::Manual::Intro#Action_types.
nick writes:
I'm not sure if this is a perl regex issue, or a Catalyst issue. Any ideas?
How about simply trying it out?
repl>>> $_ = '/foo/21/bar/56'
/foo/21/bar/56
repl>>> m|foo/(\d+)(?:/bar/(\d+))?|
$VAR1 = 21;
$VAR2 = 56;
repl>>> $_ = '/foo/21'
/foo/21
repl>>> m|foo/(\d+)(?:/bar/(\d+))?|
$VAR1 = 21;
$VAR2 = undef;

Can I overload Perl's =? (And a problem while use Tie)

I choose to use tie and find this:
package Galaxy::IO::INI;
sub new {
my $invocant = shift;
my $class = ref($invocant) || $invocant;
my $self = {']' => []}; # ini section can never be ']'
tie %{$self},'INIHash';
return bless $self, $class;
}
package INIHash;
use Carp;
require Tie::Hash;
#INIHash::ISA = qw(Tie::StdHash);
sub STORE {
#$_[0]->{$_[1]} = $_[2];
push #{$_[0]->{']'}},$_[1] unless exists $_[0]->{$_[1]};
for (keys %{$_[2]}) {
next if $_ eq '=';
push #{$_[0]->{$_[1]}->{'='}},$_ unless exists $_[0]->{$_[1]}->{$_};
$_[0]->{$_[1]}->{$_}=$_[2]->{$_};
}
$_[0]->{$_[1]}->{'='};
}
if I remove the last "$[0]->{$[1]}->{'='};", it does not work correctly.
Why ?
I know a return value is required. But "$[0]->{$[1]};" cannot work correctly either, and $[0]->{$[1]}->{'='} is not the whole thing.
Old post:
I am write a package in Perl for parsing INI files.
Just something based on Config::Tiny.
I want to keep the order of sections & keys, so I use extra array to store the order.
But when I use " $Config->{newsection} = { this => 'that' }; # Add a section ", I need to overload '=' so that "newsection" and "this" can be pushed in the array.
Is this possible to make "$Config->{newsection} = { this => 'that' };" work without influence other parts ?
Part of the code is:
sub new {
my $invocant = shift;
my $class = ref($invocant) || $invocant;
my $self = {']' => []}; # ini section can never be ']'
return bless $self, $class;
}
sub read_string {
if ( /^\s*\[\s*(.+?)\s*\]\s*$/ ) {
$self->{$ns = $1} ||= {'=' => []}; # ini key can never be '='
push #{$$self{']'}},$ns;
next;
}
if ( /^\s*([^=]+?)\s*=\s*(.*?)\s*$/ ) {
push #{$$self{$ns}{'='}},$1 unless defined $$self{$ns}{$1};
$self->{$ns}->{$1} = $2;
next;
}
}
sub write_string {
my $self = shift;
my $contents = '';
foreach my $section (#{$$self{']'}}) {
}}
Special Symbols for Overload
lists the behaviour of Perl overloading for '='.
The value for "=" is a reference to a function with three arguments, i.e., it looks like the other values in use overload. However, it does not overload the Perl assignment operator. This would go against Camel hair.
So you will probably need to rethink your approach.
This is not exactly JUST operator overloading, but if you absolutely need this functionality, you can try a perl tie:
http://perldoc.perl.org/functions/tie.html
Do you know about Config::IniFiles? You might consider that before you go off and reinvent it. With some proper subclassing, you can add ordering to it.
Also, I think you have the wrong interface. You're exposing the internal structure of your object and modifying it through magical assignments. Using methods would make your life much easier.