DEV Community: DragosTrif

Testing a Perl Mojolicious web app

DragosTrif — Mon, 25 Aug 2025 21:50:44 +0000

This post assumes that you know you way around Mojolicious web framework. If not you should start here:

Testing web applications be can tricky because it involves many different components like the html, java script, css, databases and last but not least the Perl code.
Fortunately the Perl ecosystem is very rich in test libraries.

For the purpose of this article I will use the following libraries:

Test2::V0 
Test::Mojo 
DBD::Mock::Session::GenerateFixtures
Sub::Override
Playwright
Proc::Background
File::Path
File::Copy

For our first test, we’ll use Test::Mojo, the official testing helper for Mojolicious. It provides a rich set of methods for simulating HTTP requests and making assertions about web applications. Best of all, it can run tests without requiring a Mojolicious server to be running.

Now let's break down what we need to do. First, we need to use some sort of test database. There are many options here. Personally, I like to create fixtures using DBD::Mock::Session::GenerateFixtures module, a thin wrapper over DBD::Mock that generates fixtures by copying them into a JSON file when a real dbh is provided. Aftter the mocked is generated I Sub::Override to make sure the real dbh is overridden by the mocked one.

Using Test::Mojo

use strict;
use warnings;

use Mojo::Base -strict;

use Test2::V0;
use Test::Mojo;

my $override = Sub::Override->new();
my $db =  MyApp::DB->new(domain => 'development', type => 'main');
# when dbh attribute is set it copies data in t/db_fixtures/02_login.t.json
#  when dbh attribute is not set will use the test name to relove the fixture file
my $mock_dumper = DBD::Mock::Session::GenerateFixtures->new({dbh => $db->dbh()});
# override in the app the dbh
$override->replace('Rose::DB::dbh' => sub {return  $mock_dumper->get_dbh})

With this approach after the fixtures file is generated we can start using Test::Mojo with the web server down.
No lets add some tests in our code:


subtest 'test login with correct user and password' => sub { 
     $t->get_ok('/')->status_is(200);
    my $login_url = $t->tx->res->dom->find('a')->grep(qr/login/)->map(attr => 'href')->first;
    ok($login_url, "Found Login link pointing to $login_url");

    my $response = $t->post_ok($login_url => form => { username => 'Diana', password => 'password' });
    $response->status_is(302);
    my $cookie = $response->tx->res->cookies->[0];
    is($cookie->name, 'mojolicious', "The Mojolicious session cookie is set");
    ok(length $cookie->value, "Cookie has a value");

    my $redirect_url = $response->tx->res->headers->location();
    my $followed = $t->get_ok($redirect_url)->status_is(200);
    my $log_out_url = $response->tx->res->dom->find('a')->grep(qr/logout/)->map(attr => 'href')->first;
    ok($log_out_url, "Found login out link pointing to $log_out_url");
};

Save everything in a file t/login.t and run:

carton exec -- prove -v t/login.t

This should generate a similar output:

[2025-08-24 14:35:14.51780] [643942] [trace] [tMiiGo7o61v9] GET "/"
[2025-08-24 14:35:14.51799] [643942] [trace] [tMiiGo7o61v9] Routing to controller "SkinCare::Controller::Welcome" and action "landing_page"
[2025-08-24 14:35:14.51848] [643942] [trace] [tMiiGo7o61v9] Rendering template "example/welcome.html.ep"
[2025-08-24 14:35:14.51933] [643942] [trace] [tMiiGo7o61v9] Rendering template "layouts/default.html.ep"
[2025-08-24 14:35:14.52067] [643942] [trace] [tMiiGo7o61v9] 200 OK (0.002865s, 349.040/s)

ok 1 - test login with correct user and password {
    ok 1 - GET /
    ok 2 - 200 OK
    ok 3 - Found Login link pointing to /login
    ok 4 - POST /login
    ok 5 - 302 Found
    ok 6 - GET /welcome/1
    ok 7 - 200 OK
    ok 8 - Found login out link pointing to /logout
    ok 9 - The Mojolicious session cookie is set
    ok 10 - Cookie has a value
    1..10
}

So what just happened:

loaded the landing and tested the status:
$t->get_ok('/')->status_is(200)
Then we searched for the login url inside the dom using Mojo::Dom:
$t->tx->res->dom->find('a')->grep(qr/login/)->map(attr => 'href')->first
Submitted the login form and tested the response

 $response->status_is(302);
    my $cookie = $response->tx->res->cookies->[0];
    is($cookie->name, 'mojolicious', "The Mojolicious session cookie is set");
    ok(length $cookie->value, "Cookie has a value");;

Checked that the user home page loaded successfully by searching for links:

my $redirect_url = $response->tx->res->headers->location();
    my $followed = $t->get_ok($redirect_url)->status_is(200);
    my $log_out_url = $response->tx->res->dom->find('a')->grep(qr/logout/)->map(attr => 'href')->first;
    ok($log_out_url, "Found login out link pointing to $log_out_url");

This small tests hit all my code and illustrates the advantages of Test::Mojo:

No extra setup.
Easy to parse the DOM with it.
Can run tests without the server being up.

Using Playwright:

If you need to test JavaScript and Test::Mojo quickly reaches its limits. A good alternative to it is the Perl client for Playwright.
Because Playwright requires the web server to be up an running several tweaks are required:

You need to install nodejs and friends:

apt-get install -y nodejs
npm install -g playwright
npx playwright install --with-deps chromium
npm install -g express

You need to integrated the mock mechanism in the application code:

if ($ENV{FIXTURES_PATH}) {
    if ($ENV{GENERATE_FIXTURES}) {
        my $override = Sub::Override->new();
        my $mock_dumper = DBD::Mock::Session::GenerateFixtures->new({dbh => __PACKAGE__->new(domain => 'development', type => 'main')->dbh()});
        $override->replace('Rose::DB::dbh' => sub {return  $mock_dumper->get_dbh});
        move "script/db_fixtures/skin_care.json", $ENV{FIXTURES_PATH};
    } elsif($ENV{USE_FIXTURES}) {

        my $override = Sub::Override->new();
        my $mock_dumper = DBD::Mock::Session::GenerateFixtures->new(file => $ENV{GENERATE_FIXTURES_PATH});
        $override->replace('Rose::DB::dbh' => sub {return  $mock_dumper->get_dbh});
    }
}

You need a test that can start and stop your server:

my $proc = Proc::Background->new("carton exec -- morbo ../skin_care/script/skin_care") or die "$!";
sleep 3; 
...
if ($proc->alive) {
  $proc->terminate;
  $proc->wait;
}

Playwright test setup:

use strict;
use warnings;

use Test2::V0;

use English    qw ( -no_match_vars );
use Data::Dumper;
use Playwright;
use Proc::Background;
use File::Path qw( rmtree );

use feature 'say';

my $handle = Playwright->new();
my $browser = $handle->launch( headless => 0, type => 'chrome' );
my $page = $browser->newPage();
$ENV{GENERATE_FIXTURES} = 0;
my ($volume, $directory, $test_file) = File::Spec->splitpath($PROGRAM_NAME);
$ENV{FIXTURES_PATH} = "t/db_fixtures/$test_file.json";
$ENV{USE_FIXTURES} = 1;

my $proc = Proc::Background->new("carton exec -- morbo ../skin_care/script/skin_care") or die "$!";
sleep 3;

This above sets the env vars used by the application to determine if it generate or use a fixture file for or test and sets up the browser.

Example Playwright test:

my $res = $page->goto('http://127.0.0.1:3000/login', { waitUntil => 'networkidle' });
$page->screenshot({path => '01_load_form.png'});
is($res->status(), 200, 'login form is ok');


$page->fill('input[name="username"]', 'Diana');
$page->fill('input[name="password"]', 'password');
$page->screenshot({path => '02_populate_form_from.png'});
$page->click('input[type="submit"].btn-primary');

my $cookies = $page->context->cookies();

is($cookies->[0]->{name}, 'mojolicious', "The Mojolicious session cookie is set");
ok(length $cookies->[0]->{value}, "Cookie has a value");

$page->screenshot({path => '03_user_home.png'});
my $create_routine_locator =  $page->locator('#create_routine');
my $create_routine_menu = $create_routine_locator->allInnerTexts()->[0];
is($create_routine_menu, 'Create a routine', 'Create routine menu is ok');


$create_routine_locator->click();

$page->waitForSelector('#btn-1', { state => 'visible', timeout => 5000 });
$page->click('#btn-1');
sleep 3;
$page->screenshot({path => '04_user_sub_menu.png'});
my $create_routine_content_locator = $page->locator('#content-1');

ok($create_routine_content_locator->count() > 0, 'Found #content-1 in the DOM');

So what just happened:

loaded the landing and tested the status
Fill the input fields with the credentials and submitted the form
Tested the login via the cookies
Use various methods like click or locator to interact and test the page.
create snapshots with of the various tested process for an human review.

[Boost]

DragosTrif — Sat, 03 May 2025 19:57:54 +0000

DragosTrif

Apr 27 '25

Mojolicious and Docker

#docker #perl #devops #mojolicious

Comments 2

2 min read

Mojolicious and Docker part 2

DragosTrif — Wed, 30 Apr 2025 21:59:40 +0000

I my last post mojolicious-and-docker I have explained how to build and Docker image and to spin up which holds an Mojo app in this one I want to add show how to:

Add an data base image to the docker compose file
Create an network between the and the app
Create and persists your db
Start the Docker in the containers in the correct order

So lets start.
In the compose.yaml add the following lines:

database:
    image: mariadb
    ports: 
      - "3306:3306"

This code snippet will the db image.
Now add the following lines at the same level with ports in the compose file.

environment:
      MARIADB_ROOT_PASSWORD: ${DB_PASSWORD}
      MARIADB_DATABASE: ${DB_NAME}
      MARIADB_PASSWORD: ${DB_PASSWORD}
      MARIADB_USER: ${DB_USER}

This value are red from the .env file defined in at the same level with the compose file. The content of that files is similar to this:

MARIADB_ROOT_PASSWORD=<your_password>
DB_HOST=<database>
DB_USER=<your_password>
DB_PASSWORD=<your_password>
DB_NAME=<my_app>

As side note on local machine I make this entry into '/etc/hosts' to be able to connect to the db from outside the Docker container.

127.0.0.1   database

Because you do not want to lose date mount the db files for persistence using this line:

    volumes: 
      - ./maria-data:/var/lib/mysql

At this point you have an Maria db image that we know it will not lose data but nothing is actually in there. Lets address this by mounting an new volume:

- ./my_app/migrations/000_create_db.sql:/docker-entrypoint-initdb.d/000_create_db.sql

Open an editor and this lines in the 000_create_db.sql script:

CREATE DATABASE IF NOT EXISTS my_app
    CHARACTER SET utf8mb4
    COLLATE utf8mb4_unicode_ci;

This will run and create the db when you run docker compose up.
In order to make sure that everything cheeks out we need to: add health check, create and network and make sure that the app starts after the db:

So to add the health check drop this lines

healthcheck:
      test: ["CMD-SHELL", "mariadb -u${DB_USER} -p${DB_PASSWORD} -e 'SELECT 1'"]
      interval: 10s
      timeout: 5s
      retries: 5
      start_period: 30s

Then both services database and web and this line:

networks:
      - my-app-net

Then at the bottom of the file define the network:


networks:
  my-app-net:

To make sure that the app wont break add this in the web service:

 depends_on:
      database:
        condition: service_healthy

This will ensure that the app will start only after the db.
At this point we can start to think about integrating the db in into our app. First thing is first lets add all the Perl libraries into the cpan file:

requires 'File::Slurper'                        => '0.014';
requires 'Mojolicious'                          => '9.39',;
requires 'Dotenv'                               => '0.002';
requires 'DBI'                                  => ' 1.647'; 
requires 'DBD::MariaDB'                         => '1.23';
requires 'Dotenv'                               => '0.002';
requires 'Try::Tiny'                            => '0.32';
requires 'Digest'                               => '1.20';
requires 'Digest::SHA'                          => '6.04';
requires 'Mojolicious::Plugin::Authentication'  => '1.39';
requires 'Digest::Bcrypt'                       => '1.212';
requires 'DBD::Mock::Session::GenerateFixtures' => '0.11';

Now run carton install locally this will update the the cpanfile.snapshot and take of the dependencies.
Now if we type docker compose build an new image will be create with all the requires libraries baked in.
Now spin the composition with docker compose up
You should see something similar with this:

 ✔ Container my_app-database-1  Created                                                                                                                                                            0.0s 
 ✔ Container my_app-web-1       Created

No its time to put some meat and the bones at some Perl code in our app and some tables we want to use:
So create this table in the db:


CREATE TABLE IF NOT EXISTS users (
    id MEDIUMINT NOT NULL AUTO_INCREMENT,
    plugin VARCHAR(30) NOT NULL DEFAULT 'Auth',
    username VARCHAR(30) UNIQUE NOT NULL,
    user_password VARCHAR(255) CHARACTER SET utf8mb4 COLLATE utf8mb4_unicode_ci NOT NULL,
    salt VARCHAR(255) CHARACTER SET utf8mb4 COLLATE utf8mb4_unicode_ci NOT NULL,
    is_admin TINYINT(1) NOT NULL DEFAULT '0',
    PRIMARY KEY (id)
) ENGINE=InnoDB DEFAULT CHARSET=utf8mb4 COLLATE=utf8mb4_unicode_ci;

CREATE INDEX idx_plugin ON users(plugin);
CREATE INDEX idx_username ON users(username);
CREATE INDEX idx_user_password ON users(user_password);

Now in the main controller add this lines MyApp.pm inside sub start up:


  # Router
  my $r = $self->routes;

  # # # Normal route to controller
  $r->get('/')->to('Example#welcome');

  #load the login form
    $r->get('/login')->to(
        controller => 'Login',
        action     => 'login'
    );

    #submit the login form
    $r->post('/login')->to(
        controller => 'Login',
        action     => 'user_login'
    );

    my $auth_required = $r->under('/')->to('Login#user_exists');

    $auth_required->get('/welcome')->to(
        controller => 'User', action => 'welcome',
    )

Now lets add an the login link to templates/example/welcome.html.ep:


<h2><%= $msg %></h2>
<p>
  <%= link_to 'here' => '/login' %> to login.
</p>

Now lets define the login controller by creating this file:

package My_App::Controller::Login;
use Mojo::Base 'Mojolicious::Controller', -signatures;

use Data::Dumper;
use Digest;
use MIME::Base64;
use Mojolicious::Plugin::Authentication;

use lib 'lib';
use DBI;
use DBD::MariaDB;

my $dsn = "DBI:MariaDB:database=$ENV{DB_NAME};host=$ENV{DB_HOST};port={$ENV{DB_PORT}";
my $dbh = DBI->connect($dsn, $ENV{DB_USER}, $ENV{DB_PASSWORD});
sub login($self) {

    $self->render(
        template => 'login',
        error    => $self->flash('error')
    );
}

sub user_login($self) {

    # From the form
    my $password = $self->param('password');
    my $username = $self->param('username');

    # auth plugin setup
    $self->app->plugin(
        'authentication' => {
            autoload_user => 1,
            wickedapp     => 'YouAreLogIn',
            load_user     => sub($c, $user_id) {
                if ($user_id) {
                              my $query = "<<SQL";
                                   SELECT t1.id, 
                                    t1.username, 
                                    t1.user_password, 
                                    t1.salt, 
                                    t1.is_admin 
                                 FROM users t1 WHERE t1.id = ?
SQL
                                my $sth = $dbh->prepare($query);
                                $sth->execute($user_id);
                            my $user = $sth->fetchrow_hashref();
                                return $user
                   }

                return;
            },
            validate_user => sub($c, $user, $pass, $extradata) {
                my $user_key = $self->validate_user_login($user, $password);
            }

        }
    );

    my $auth_key = $self->authenticate($username, $password);

    if ($auth_key) {
        $self->flash(message => 'Login Success.');
        $self->session(user => $auth_key);
        return $self->redirect_to('/welcome');
    } else {
        $self->flash(error => 'Invalid username or password.');
        $self->redirect_to('login');
    }

}

# validate the user login
sub validate_user_login {
    my ($self, $username, $password, $extradata) = @_;

               SELECT t1.id, 
                      t1.username, 
                      t1.user_password, 
                      t1.salt, 
                      t1.is_admin 
              FROM users t1 WHERE t1.username = ?
SQL
        my $sth = $dbh->prepare($query);
        $sth->execute($password);
     my $user = $sth->fetchrow_hashref();

    my $id           = $user->{id};
    my $db_password  = $user->{user_password};
    my $salt         = $user->{salt};


    if (!defined $id) {
        return 0;
    } else {
        return validate_password($password, $db_password, $salt) ? $id : undef;
    }

    return 1;
}


sub validate_password($form_password, $db_password, $salt) {

    # $salt   = decode_base64($salt);
    my $cost   = 12;
    my $bcrypt = Digest->new(
        'Bcrypt',
        cost => $cost,
        salt => decode_base64($salt)
    );

    if ($bcrypt->add($form_password)->b64digest() eq $db_password) {
        return 1;
    }

    return 0;
}

sub user_exists($c) {
    if ($c->session('user')) {
        return 1;
    } else {
        $c->redirect_to('login');
    }
}

1;

Now lets add the login form:

<div class="container">
    <div class="card col-sm-6 mx-auto">
        <div class="card-header text-center">
            User Sign In 
        </div>
        <br /> <br />
        <form method="post" action='/login'>
            <input class="form-control" 
                   id="username" 
                   name="username" 
                   type="text" size="40"
                   placeholder="Enter Username" 
             />
            <br /> 
            <input class="form-control" 
                   id="password" 
                   name="password" 
                   type="password" 
                   size="40" 
                   placeholder="Enter Password" 
             />     
            <br /> 
            <input class="btn btn-primary" type="submit" value="Sign In">
            <br />  <br />
        </form>

        % if ($error) {
            <div class="error" style="color: red">
                <small> <%= $error %> </small>
            </div>
        %}
    </div>

</div>

    </body>
</html>

Lets refactor the db connection a bit by creating an DB package in my_app/lib folder.


package MyDatabase;

use strict;
use warnings;

use DBI;
use DBD::MariaDB;
use Carp 'croak';
use Exporter::NoWork;

sub db_handle {

  my $dsn = "DBI:MariaDB:database=$ENV{DB_NAME};host=$ENV{DB_HOST};port={$ENV{DB_PORT}";
  my $dbh = DBI->connect($dsn, $ENV{DB_USER}, $ENV{DB_PASSWORD});
 return $dbh;
}

At this point we can use an small script to insert an user in our db:

use strict;
use warnings;

use Digest::SHA qw(sha256_base64);
use Digest;
use MIME::Base64;
use lib 'lib';
use MyDatabase qw(db_handle);
use feature 'say';
my $salt = sha256_base64(time . rand() . $$);
$salt = substr($salt, 0, 16);
chomp $salt;
my $cost = 12;
my $bcrypt = Digest->new('Bcrypt', cost => $cost, salt => $salt);
my $sql = <<"SQL";
INSERT INTO users (
        salt,
        username,
        user_password,
         is_admin)
VALUES ( ?, ?, ?, ?)
SQL

 my $dbh = db_handle();
 my $r = $dbh->do($sql_license, undef, encode_base64($salt), 'Diana', $bcrypt->add('password')->b64digest(), 0);

Remember to add the dependencies to the carton file, use the new lib in Login controller and run the script to insert the new user.
Login in the app should be possible at this moment.
The last thing we need to do is provide an unit test for our app for this create an file in the t folder of you app with the following content:

use Mojo::Base -strict;

use Test2::V0;
use Test::Mojo;


use DBI;
use Dotenv;
use DBD::Mock::Session::GenerateFixtures;
use Sub::Override;
use MyDatabase qw(db_handle);
use lib 'lib';

use feature 'say';

my $mock_dumper = DBD::Mock::Session::GenerateFixtures->new({dbh => db_handle() });
my $t = Test::Mojo->new('MyApp');
$t->get_ok('/')->status_is(200);
my $login_url = $t->tx->res->dom->find('a')->grep(qr/login/)->map(attr => 'href')->first;
$t->post_ok($login_url => form => { username => 'Diana', password => 'password' })->status_is(200)
done_testing();

With your server up so it will connect to the run the unit test this will produce an mock file like this one:

[
   {
      "results" : [
         [
            1,
            "Diana",
            "IDRBjhp5KGuSQ8gqpc8bzSdU898DMK0",
            "eFV0eC96YWpJMUJwU3h2WA==",
            0
         ],
         []
      ],
      "statement" : "SELECT t1.id, t1.username, t1.user_password, t1.salt, t1.is_admin FROM users t1 WHERE t1.username = ?",
      "bound_params" : [
         "Diana"
      ],
      "col_names" : [
         "id",
         "username",
         "user_password",
         "salt",
         "is_admin"
      ]
   },
   {
      "bound_params" : [
         1
      ],
      "statement" : "SELECT id, username, user_password, salt, is_admin FROM users WHERE id = ?",
      "results" : [
         [
            1,
            "Diana",
            "IDRBjhp5KGuSQ8gqpc8bzSdU898DMK0",
            "eFV0eC96YWpJMUJwU3h2WA==",
            0
         ],
         []
      ],
      "col_names" : [
         "id",
         "username",
         "user_password",
         "salt",
         "is_admin"
      ]
   }
]

After this done do docker compose down and then edit the unit test:

my $override = Sub::Override->new();
# remove the dbh as an argument
my $mock_dumper = DBD::Mock::Session::GenerateFixtures->new();
# replace the dbh with the mocked one
$override->replace('MyDatabase::db_handle' => sub {return  $mock_dumper->get_dbh});

Now you should be able to run unit test isolated from the world wide web

Mojolicious and Docker

DragosTrif — Sun, 27 Apr 2025 17:48:48 +0000

This post plans to illustrate how you can build and dockerize and Mojolicious application and solve basic issue like volume mounts permission and env values.

Building an simple dockerized app

Prerequisites:

curl -L http://cpanmin.us | perl - App::cpanminus
cpanm --verbose Carton

At this point we can create an cpanfile and Mojolicious and some other dependencies in it.

    requires 'Mojolicious' => '9.39',

Generate the app:

carton install
carton exec -- mojo generate app

Generate the Dockerfile:

touch Dockerfile

And populated with the following lines of code:

FROM perl:latest
LABEL version="1.0"
LABEL description="Foo Bar foo.bar@gmail.com"
# add C dependencies 
RUN apt-get update && apt-get install -y \
    build-essential \
    libssl-dev \
    libxml2-dev \
    libexpat1-dev \
    zlib1g-dev \
    libpq-dev \
    libmariadb-dev \
    mariadb-client \
    libdbd-mariadb-perl \
    ssh \
    && rm -rf /var/lib/apt/lists/*  # Clean up to reduce image size
# install Carton
RUN curl -L http://cpanmin.us | perl - App::cpanminus && \
    cpanm --notest --verbose Carton
# create a new user and group for your app 
RUN groupadd -r my_app_group && useradd -r -g my_app_group -m -d /home/my_app my_app_user
# create home dir for that user 
RUN mkdir -p /home/my_app && \
    chown -R my_app_user:my_app_group /home/my_app
# switch from root to the new user 
USER my_app_user

WORKDIR /home/my_app

ENV PATH="/home/my_app/.perl/bin:${PATH}"

# Copy application dependencies and files
COPY --chown=my_app_user:my_app_group cpanfile /home/my_app
COPY --chown=my_app_user:my_app_group cpanfile.snapshot /home/my_app

# Install dependencies using Carton
RUN carton install --deployment

EXPOSE 3000

ENTRYPOINT ["carton", "exec", "--", "morbo", "my_app/script/my_app"]

Add the docker compose file:

# touch docker compose
services:
  web:
    image: my_app
    ports: 
      - "3000:3000"
    build:
      context: .
      dockerfile: Dockerfile
    working_dir: /home/my_app  # Set the working directory
    env_file:
      - .env
    volumes:
      - ./my_app:/home/my_app/my_app:ro
      - ./.env:/home/my_app/.env:ro

Now run:

  docker compose build
  docker compose up

The landing page for Mojolicious should be available at

http://127.0.0.1:3000

What just happened:
We locally ran carton install and and created an local Mojo app. Running locally carton install creates the cpanfile.snapshot that it used by the Docker image to handle the Perl module versioning.
The Docker file create an base image from perl:latest, installed essential OS dependencies, used Carton to handle Perl module dependencies, created a non-root user skin_care_user with proper permissions and setup morbo server via ENTRYPOINT directive. Then compose.yaml file mounts the application and the .env file and maps the port "3000:3000"

Generate Fixtures for Rose::DB ORM

DragosTrif — Mon, 21 Apr 2025 21:23:07 +0000

A while a go I released on Metacpan DBD::Mock::Session::GenerateFixtures. So lets how can we mock data for Mysql/Maria db via Rose::Ddb ORM.

So lets install this:

sudo apt-get install -y mysql-server mysql-client libmysqlclient-dev
cpanm DBD::Mock::Session::GenerateFixtures

At this point we can work on our unit test:

use Test2::V0;

use lib        qw(lib);

use DBI;
use Data::Dumper;
use DBD::Mock::Session::GenerateFixtures;
use Rose::DB::Object::Loader;
use Sub::Override;
use File::Path qw(rmtree);

# first connect to your db
my $db = DB->new(
    domain => 'mysql',
    type   => 'mysql'
);

# pass the real dbh to DBD::Mock::Session::GenerateFixtures
my $mock_dumper = DBD::Mock::Session::GenerateFixtures->new({dbh => $db->dbh()});

my $num_rows_updated = DB::Media::Manager->update_media(
        set => {
            location => '/data/music/claire_de_lune.ogg',
        },
        where => [
            id => 2,
        ],
    );

is($num_rows_updated, 1, 'update media table is ok');

After the data is collected an JSON file it can be accessed by our test in the next run. Some extra lined need to be added for insert, update and delete to work as expected.


my $mock_dumper = DBD::Mock::Session::GenerateFixtures->new();
# get the mocked dbh
my $dbh         = $mock_dumper->get_dbh();

my $override = Sub::Override->new();
my $last_insert_id    = 4;
my $update_or_deleted = 1;
# override the dbh
$override->replace('Rose::DB::dbh' => sub {return $dbh});
# override last inserted id
$override->replace('Rose::DB::MySQL::last_insertid_from_sth' => sub {$last_insert_id++; return $last_insert_id});
# override rows 
$override->replace('DBD::Mock::st::rows' => sub {return 1});

A full unit test example can be seen here:
test_rose_db_with_mysql
Bibliography
Rose::DB ORM
Generate Fixtures for DBD::Mock::Session
Testing with a real database

Rose::DB ORM and Perl

DragosTrif — Sun, 12 Jan 2025 18:28:34 +0000

A while ago I found out from a post that Dbix::Class Perls default ORM is abandoned dbixclass not updated. So I started to look around to see what else is out there on metacpan and can be used as an alternative.
This is how I found Rose::DB an ridiculously fast and fun ORM.
In this post I plan to show to you how get started with this.
The first step is to create a DB for this I will use SQLite.
So lets start by installing dependenceies:

# install sqlite3
sudo apt install sqlite3
# verify Installation
sqlite3 --version
cpanm Rose::DB
cpanm Rose::DB::Object
cpanm Rose::DB::Object::Manager

Now create a lib directory an place in it a file namedDB.pm with the following content:

package DB;

use strict;
use warnings;

use Rose::DB;
use base qw(Rose::DB);

# Use a private registry for this class
__PACKAGE__->use_private_registry;


# Register your lone data source using the default 'main' and domain 'development'

__PACKAGE__->register_db(
  domain   => 'development',
  type     => 'main',
  driver   => 'sqlite',
  database => './file.db',
  connect_options =>
  {
    RaiseError => 1, 
    AutoCommit => 1,
    PrintError => 0,
    sqlite_trace => 1,
  }
);

1;

At this point we can use the DB.pm package to build our database.
So create a db file and to it this content:

use strict;
use warnings;

use lib 'lib';

use DB;


my $db = DB->new(domain => 'development', type => 'main');

my $sql_media_type = <<"SQL";
CREATE TABLE IF NOT EXISTS media_types (
id INTEGER PRIMARY KEY,
media_type VARCHAR(10) NOT NULL
);
SQL

my $sql_license = <<"SQL";
CREATE TABLE IF NOT EXISTS licenses (
    id   INTEGER PRIMARY KEY,
    name VARCHAR(255) NOT NULL,
    allows_commercial BOOLEAN NOT NULL
);
SQL

my $sql_media = <<"SQL";
CREATE TABLE IF NOT EXISTS media (
id INTEGER PRIMARY KEY,
name VARCHAR(255) NOT NULL,
location VARCHAR(255) NOT NULL,
source VARCHAR(511) NOT NULL,
attribution VARCHAR(255) NOT NULL,
media_type_id INTEGER NOT NULL,
license_id INTEGER NOT NULL,
FOREIGN KEY (media_type_id) REFERENCES media_types(id),
FOREIGN KEY (license_id)
REFERENCES licenses(id)
);
SQL

# create db;
$db->dbh->do($sql_media_type) or die $db->dbh->errstr;
$db->dbh->do($sql_license) or die $db->dbh->errstr;
$db->dbh->do($sql_media) or die $db->dbh->errstr;

Now the db is created we need to define the DB objects and insert some data to play around with it. So we need to created this files structure:

── lib
      ├── DB
         ├── Licenses.pm
         ├── Media.pm
         └── Media_Types.pm

Each class corresponds to a table and we need to add the code to make this work for each of them. So lets start:


 package DB::Media;

use strict;
use warnings;


use DB;
use base qw(Rose::DB::Object);

my $db = DB->new(domain => 'development', type => 'main');

__PACKAGE__->meta->setup
(
  table => 'media',
   columns => [
        id            => { type   => 'serial', primary_key => 1 },
        name          => { type   => 'varchar', length => 255 },
        location      => { type   => 'varchar', length => 255 },
        source        => { type   => 'varchar', length => 511 },
        attribution   => { type   => 'varchar', length => 255 },
        media_type_id => { type   => 'integer'                },
        license_id    => { type   => 'integer'                },
    ],
    relationships => [
        media_type => {
            type       => 'one to one',
            class      => 'DB::Media_Types',
            column_map => { media_type_id => 'id' },
        },
      licenses => {
        type       => 'one to one',
        class      => 'DB::Licenses',
        # media.media_id -> license.id
        column_map => { license_id => 'id' },
        },
      ]
);

sub init_db { $db };

package DB::Licenses;

use strict;
use warnings;


use DB;
use base qw(Rose::DB::Object);

my $db = DB->new(domain => 'development', type => 'main');

__PACKAGE__->meta->setup
(
  table => 'licenses',
   columns => [

        id                => { type   => 'serial', primary_key => 1 },
        name              => { type   => 'varchar', length => 255   },
        allows_commercial => { type   => 'varchar', length => 255   },
    ],
    relationships => [
        licenses => {
            type       => 'one to many',
            class      => 'DB::Media',
             # licenses.id -> media.license_id
            column_map => { id => 'license_id' },
        },
    ]
);

sub init_db { $db };

1;

package DB::Media_Types;

use strict;
use warnings;


use DB;
use base qw(Rose::DB::Object);

my $db = DB->new(domain => 'development', type => 'main');

__PACKAGE__->meta->setup
(
   table => 'media_types',
  columns => [
        id         => { type   => 'serial',  primary_key => 1 },
        media_type => { type   => 'varchar', length => 10    },
    ],
    relationships => [
        media_type => {
            type       => 'one to many',
            class      => 'DB::Media',
            column_map => { id => 'media_type_id' },
        },

    ]
);

sub init_db { $db };

1;

With this step done we can start to insert data into our tables using this script:

use strict;
use warnings;

use lib 'lib';

use DB::Media_Types;
use DB::Licenses;
use DB::Media;

my @types = qw(video audio image);
my %media_type_id_for;
my %license_id_for;

foreach my $media (@types) {
    my $media_obj = DB::Media_Types->new(media_type => $media);
    $media_obj->save();
    $media_type_id_for{$media} = $media_obj->id();

}

my @licenses =
    (['Public Domain', 1], ['Attribution CC BY', 1], ['Attribution CC BY-SA', 1], ['Attribution-NonCommercial CC BY-NC', 0],);


foreach my $license (@licenses) {
    my $license_obj = DB::Licenses->new(
        name              => $license->[0],
        allows_commercial => $license->[1]
    );
    $license_obj->save();
    $license_id_for{$license->[0]} = $license_obj->id();
}


my @media = ([
        'Anne Frank Stamp',
        '/data/images/anne_fronk_stamp.jpg',
        'http://commons.wikimedia.org/wiki/File:Anne_Frank_stamp.jpg', 
        'Deutsche Post',
        $media_type_id_for{'image'},
        $license_id_for{'Public Domain'},
    ],
    [
        'Clair de Lune', 
        '/data/audio/claire_de_lune.ogg',
        'http://commons.wikimedia.org/wiki/File:Sonate_Clair_de_lune.ogg', 
        'Schwarzer Stern',
        $media_type_id_for{'audio'}, 
        $license_id_for{'Public Domain'},
    ],
    );

foreach my $media (@media) {
   my $media_record_object = DB::Media->new(
     name     => $media->[0],
     location => $media->[1],
     source   => $media->[2],
     attribution => $media->[3],
     media_type_id => $media->[4],
     license_id =>  $media->[5],
   );

   $media_record_object->save();
}

With data inserted into our data base we can now try a select:

use strict;
use warnings;

use Data::Dumper;

use lib 'lib';
use feature 'say';

use DB::Media;

my $media = DB::Media->new(id => 1);
$media->load or die $media->error;

say "Media Name: ", $media->name;
say "Media Type: ", $media->media_type->media_type();
say "Allows_commercial: ", $media->licenses->allows_commercial();

Please notice how the Media object has access to data from media_type and licenses table.
In the background it will run this queries to fetch the data

SELECT id, name, location, source, attribution, media_type_id, license_id FROM media WHERE id = 1
SELECT id, media_type FROM media_types WHERE id = 3
SELECT id, name, allows_commercial FROM licenses WHERE id = 1

How ever the recommended approach is to created an manger class.

package DB::Media::Manager;

use strict;
use warnings;

use base 'Rose::DB::Object::Manager';

sub object_class { 'DB::Media' };

__PACKAGE__->make_manager_methods('media');

1;

This class will open your add to your code the following methods:


get_media
get_media_iterator
get_media_count
update_media
delete_media

This will also allow to create more complicated queries:

my $products =  DB::Media::Manager->get_media(
    with_objects => [ 'media_type', 'licenses' ],
    query        => [
        't2.id' => 2,
    ]
);

This will result in this select:

SELECT
    t1.id,
    t1.name,
    t1.location,
    t1.source,
    t1.attribution,
    t1.media_type_id,
    t1.license_id,
    t2.id,
    t2.media_type,
    t3.id,
    t3.name,
    t3.allows_commercial
FROM
    media t1
LEFT OUTER JOIN media_types t2 ON
    (t1.media_type_id = t2.id)
LEFT OUTER JOIN licenses t3 ON
    (t1.license_id = t3.id)
WHERE
    t2.id = 2

Bibliography

Beginning Perl by Curtis 'Ovid' Poe
Rose::DB
Rose::DB::Object

Generate Fixtures for DBD::Mock::Session

DragosTrif — Mon, 29 Apr 2024 06:43:50 +0000

A while ago I discovered DBD::Mock and it looked like a great tool to use in Perl unit tests. However the challenge of generating the fixtures was not always easy.
In order to solve this issue I have put together a small library that should help generate the fixture data needed.
At the core this very simple, I have mocked DBI subs in order to capture the necessary information and stored it into a file:
The first step was to generate an override object and store it on $self:

package DBD::Mock::Session::GenerateFixtures;
use Sub::Override;
...

our $override           = Sub::Override->new();
sub new {
 $self->{override}      = $override;
}

Then we can use this to mock DBI code like in the following example:

sub _override_dbi_execute {
    my $self        = shift;
    my $dbi_execute = shift;

    my $orig_execute = \&$dbi_execute;

    $self->get_override_object()->replace(
        $dbi_execute,
        sub {
            my ($sth, @args) = @_;

            my $sql = $sth->{Statement};

            my $col_names = $sth->{NAME};
            my $retval    = $orig_execute->($sth, @args);

            my $rows       = $sth->rows();
            my $query_data = {
                statement    => $sql,
                bound_params => \@args,
                col_names    => $col_names,
            };

            my $result = [];
            if ($rows > 0) {
                foreach my $row (1 .. $rows) {
                    push @{$result}, [];
                }
                $query_data->{results} = $result;
            }

            $query_data->{bound_params} = $self->{bind_params}
                if scalar @{$self->{bind_params}} > 0;

            push @{$self->{result}}, $query_data;
            $self->_write_to_file();
            $self->{bind_params} = [];
            $self->{sth}         = $sth;
            return $retval;
        }
    );

    return $self;
}

This code works for do or prepare and execute when you are trying to mock insert, update or delete statements like is this example:

subtest 'upsert generate mock data' => sub {
    my $dbh = db_handle('test.db');

    build_tests_db($dbh);
    populate_test_db($dbh);

    my $obj = DBD::Mock::Session::GenerateFixtures->new({dbh => $dbh});
    $dbh = $obj->get_dbh();

    my $sql_license = <<"SQL";
INSERT INTO licenses (name, allows_commercial) VALUES ( ?, ? )
SQL

    chomp $sql_license;
    my $r = $dbh->do($sql_license, undef, 'test_license', 'no');
    is($r, 1, 'one row inserted is ok');

    my $update_sql = 'update licenses set allows_commercial = ? where id > ?';
    $r = $dbh->do($update_sql, undef, 'yes', '3');
    is($r, 2, 'update works ok');

    $r = $dbh->do($update_sql, undef, 'yes', '100');

    is($r, '0E0', 'now rows updated');

    my $delete_sql = 'DELETE FROM licenses WHERE id = ?';
    my $sth        = $dbh->prepare($delete_sql);
    $sth->execute(3);

    is($sth->rows(), 1, 'delete with prepare and execute is ok');

    $obj->restore_all();
    $dbh->disconnect();
};

The the following data is stored in a Json file:

[
   {
      "statement" : "INSERT INTO licenses (name, allows_commercial) VALUES ( ?, ? )",
      "results" : [
         []
      ],
      "col_names" : [],
      "bound_params" : [
         "test_license",
         "no"
      ]
   },
   {
      "bound_params" : [
         "yes",
         "3"
      ],
      "statement" : "update licenses set allows_commercial = ? where id > ?",
      "col_names" : [],
      "results" : [
         [],
         []
      ]
   },
   {
      "col_names" : [],
      "statement" : "update licenses set allows_commercial = ? where id > ?",
      "bound_params" : [
         "yes",
         "100"
      ]
   },
   {
      "statement" : "DELETE FROM licenses WHERE id = ?",
      "col_names" : [],
      "results" : [
         []
      ],
      "bound_params" : [
         3
      ]
   }
]

Please observe how the results key is populate with an empty array for each row touched by our statement and it is ready to be used when a DBD::Mock::Session object is built.
For select statements you need a extra layer of mocking in order to store the exact values a select could use.
Here is how the mock for fetchrow_hashref looks like:


sub _override_dbi_fetchrow_hashref {
    my $self             = shift;
    my $fetchrow_hashref = shift;

    my $orig_selectrow_hashref = \&$fetchrow_hashref;

    $self->get_override_object()->replace(
        $fetchrow_hashref,
        sub {
            my ($sth) = @_;

            my $retval = $orig_selectrow_hashref->($sth);

            if (ref $retval) {
                my $query_results = $self->_set_hashref_response($sth, $retval);
                push @{$self->{result}->[-1]->{results}}, $query_results;
                $self->_write_to_file();
            }

            return $retval;
        }
    );

    return $self;
}

This produces the following data by pushing the each row in the result key:

[
   {
      "statement" : "SELECT * FROM media_types WHERE id IN(?,?)",
      "col_names" : [
         "id",
         "media_type"
      ],
      "results" : [
         [
            1,
            "video"
         ],
         [
            2,
            "audio"
         ]
      ],
      "bound_params" : [
         2,
         1
      ]
   }
]

Form this point one I just need to make sure that every way in which DBI lets you get the data is covered by my code. In the end I end it mocking the following subs:

Readonly::Hash my %MOCKED_DBI_METHODS => (
    execute            => 'DBI::st::execute',
    bind_param         => 'DBI::st::bind_param',
    fetchrow_hashref   => 'DBI::st::fetchrow_hashref',
    fetchrow_arrayref  => 'DBI::st::fetchrow_arrayref',
    fetchrow_array     => 'DBI::st::fetchrow_array',
    selectall_arrayref => 'DBI::db::selectall_arrayref',
    selectall_hashref  => 'DBI::db::selectall_hashref',
    selectcol_arrayref => 'DBI::db::selectcol_arrayref',
    selectrow_array    => 'DBI::db::selectrow_array',
    selectrow_arrayref => 'DBI::db::selectrow_arrayref',
    selectrow_hashref  => 'DBI::db::selectrow_hashref',
);

If you want to give this a try you can get the full code from this url:
DBD-Fixtures

Test web API's with Perl and Cucumber

DragosTrif — Mon, 31 Jan 2022 16:24:15 +0000

Behavior-Driven Development is an agile software development process that encourages teams to use conversation and concrete examples to formalize a shared understanding of how the application should behave.
Cucumber Open is the world's leading tool for BDD.

In this tutorial I want to show to you how to test web API using
Test::BDD::Cucumber, Mojo::UserAgent and Test2::V0 modules.

First we need to install Carton the Perl module dependency manager.

cpanm Carton

Now we can mock an API using Mojolicious lite web-framework.

Create a cpanfile:

touch cpanfile

Add Mojolicious web-framework to the cpanfile:

requires 'Mojolicious';

Install Mojolicious using carton:

carton install

Generate a Mojolicious lite app:

carton exec -- mojo generate lite-app mock.pl

Edit the mock.pl to return a json:

#!/usr/bin/env perl
use Mojolicious::Lite -signatures;

any '/json' => sub ($c) {
  my $dc_name = $c->param('dc');

  my $api_data_centers = {
    ro => { dc => 'ro', machine => '10.0.0.1', os => 'linux mint'},
    uk => { dc => 'uk', machine => '10.0.0.2', os => 'ubuntu' }
  };

  $c->render( json => $api_data_centers->{lc $dc_name} );
};

app->start;

Start the server:

carton exec -- morbo mock.pl
# you can test the API at this url:
# http://127.0.0.1:3000/json?dc=ro

After the server is up and running we can move to the Cucumber part.

Create the Test::BDD::Cucumber file structure:

test_api/
└── features
    ├── step_definitions
    │   └── test_api_steps.pl
    └── test_api.feature

Add Cucumber and test modules to cpanfile file:

requires 'Test::BDD::Cucumber';
requires 'Test2::V0';
requires 'Test::BDD::Cucumber::Harness::Html';

Install Cucumber and test modules:

carton install

Edit the feature file

Open the test_api/features/test_api.feature and add in this snippet:

Feature: Test a basic api with Test::BDD::Cucumber
  Test a basic api with Test::BDD::Cucumber

  Background:
   I get the request object

    Scenario: test api request
      Given I query for the RO data center
      When I make a GET request to the url /json
      Then http code is <code>

      Examples:
        | code  |
        | 200   |

To understand the above example you need some basic knowledge about the gherkin verbs:

Given is used for a predefined action.
When is used for an action done by the user (making a request).
Then is used for evaluating the user action.
And duplicates the verb above
But duplicates the verb above

Also as you can see that variables can be added to the feature file using the Examples table.
Running carton exec -- local/bin/pherkin test_api/ will display all the scenario steps in orange. This means that code to implement them was not written yet.

Writing step definitions

Open the test_api/features/step_definitions/test_api_steps.pl and add in this code snippet:


use strict;
use warnings;

use Test::BDD::Cucumber::StepFile;
use Mojo::UserAgent;
use Mojo::URL;
use Test2::V0;

Before
  sub {
    my $ua = Mojo::UserAgent->new();
    S->{ua} = $ua;
    note("we have a Mojo::UserAgent obj in S");
    return 1;
  };

Given qr/I use the (\w+) data center/ => sub {
  S->{query} = { dc => C->matches()->[0] },
  return 1;
};

When qr/I make a (\w+) request to the url ([\w\W]+)/ =>  sub {
  my $ua = S->{ua};
  my $endpoint = C->matches()->[1];
  my $http_verb = lc C->matches()->[0];

  my $url = Mojo::URL->new();
  $url->scheme('http');
  $url->host('127.0.0.1');
  $url->port('3000');
  $url->query( S->{query} );
  $url->path(lc $endpoint);

  my $tx = $ua->insecure(1)->$http_verb( $url => { Accept => 'application/json'} );

  note (  "Request:\n", '-' x 50, "\n",
    join( ' ',
    $tx->req->method,
    $tx->req->url->path,
    'HTTP/' . $tx->req->version ),
    "\n", $tx->req->headers->to_string );


  my $res = $tx->result();

  note("Reponse:\n", '-' x 50, "\n");
  note($res->body());
  note("Reponse code:\n", '-' x 50, "\n");
  note($res->code);

  S->{result} = $res;

  return 1;
};

Then qr/http code is (\d+)/ => sub {
  my $expected = C->matches()->[0];
  my $got = S->{result}->code();

  is($got, $expected, 'status code is ok');

  return 1;
};

Running carton exec -- local/bin/pherkin test_api/ will display all the scenario steps in green, showing you that everything is ok.

Understanding "S" and "C" objects
The "S" and "C" objects are automatically created. "S" stores data for the duration of a scenario while "C" stores data for the duration of a step. Calling C->matches() will get you an array with all the matches the regex did in the current step. You can use instead regex capture groups like $1 if you prefer it.

How everything worked together:

The Background code in the feature file executed the Before block in the step file which adds Mojo::UserAgent object and stores it in S.
Given qr/I query for the (\w+) data center/ This step adds the {dc => 'ro' } hash on S. Later this is used to add this ?dc=ro part to the request query.
When I make a GET request to the url /json
This step does a bunch of things:
1. reads the http verb and the url passed to him from the feature file and uses them to create Mojo::URL->new();
2. makes a request using the object Mojo::UserAgent object stored in S.
3. uses the Test2::V0 note() subroutine to document what happened.
4. stores the request response in S->{result};
Then http code is 200
This step reads the expect status code sent in from the feature file using a regex and compares it with whatever value we have stored in the response object.

Creating a library for common steps

If your team manages more then one API you don't want to rewrite the same tests over and over again for obvious reasons.
Cucumber allows you to have such steps libraries:

mkdir lib
vim lib/Steps.pm

Now move this step Then qr/http code is (\d+)/to a new lib.

package Steps;
use strict;
use warnings;

use Test::BDD::Cucumber::StepFile;
use Test2::V0;

Then qr/http code is (\d+)/ => sub {
  my $expected = C->matches()->[0];
  my $got = S->{result}->code();

  is($got, $expected, 'status code is ok');

  return 1;
};

1;

Then make sure you load the lib in test_api/features/step_definitions/test_api_steps.pl.

use lib 'lib';
use Steps;

Running the code again should result in a pass.

Using tags

If a feature has more than one scenario and you don't want to run them all at once you can use tags:

    @json_tag @all
    Scenario: test api json request
      Given I query for the RO data center
      When I make a GET request to the url /json
      Then http code is <code>

      Examples:
        | code  |
        | 200   |

   @xml_tag @all
    Scenario: test api xml request
      Given I query for the RO data center
      When I make a GET request to the url /xml
      Then http code is <code>

      Examples:
        | code  |
        | 200   |

Call the json scenario:

carton exec -- local/bin/pherkin --tags=@json_tag test_api/

Run all scenarios, except the xml one:

carton exec -- local/bin/pherkin --tags=~@xml_tag test_api/

Generating an html report

To generate an html report use this:

carton exec -- local/bin/pherkin -o Html test_api/ > test.html
#  -o Html flag calls Test::BDD::Cucumber::Harness::Html harness

The result should look like this:

If you click open a step you will see the details reported by note()

Integration with prove

carton exec -- prove -rv --source Perl --ext=.t --source Feature --ext=.feature test_api/

Bibliography

Perl Roles

DragosTrif — Fri, 14 Jan 2022 15:34:14 +0000

1. Roles Definition

A role is a set of methods that provide extra behavior to a class. Roles can't be used independently they need a class to consume them. Roles are a good alternative to inheritance.

2. A sample role

A role is declared in a *.pm file.

package Role::JSON;
use Moose::Role;

use JSON 'encode_json';

requires qw( data );

sub to_json {
  my $self = shift;

  return encode_json( $self->data() );
}

1;

3. Consuming a role

In the previous example the Role::JSON requires
the consuming class to have a method named data().

package Foo;
use Moose;
with "Role::JSON";

sub data {
 my $self = shift;
 return { foo => 'bar' }; 
}

__PACKAGE__->meta->make_immutable;

1;

Then you could just call the method defined in the role in your program:


my $obj = Foo->new();

print $obj->to_json();

# And that prints the following JSON
# { foo : 'bar' }

4. Checking if class consumes a role

Because roles are not inherited you cannot use isa() to check if a class consumes a role instead you should use does():

$object->does("Role::JSON");

5. Roles without Moose/Moo

Cpan module Role::Tiny allows you to use roles with vanilla OOP not just with Moose or Moo. Like Moose or Moo, Role::Tiny applies strict and warnings to the caller.

package Role::Foo;
use Role::Tiny;
sub data { 
 my $self = shift; 
 return { foo => 'bar' };
}
1;

package Bar;
use lib 'lib';
use Role::Tiny::With;
with  'Role::Foo';
....
1;

Role::Tiny makes available to your role the following method modifiers: before, around and after.
In this example when $self->data is called the around block executes and you get JSON returned.

package Role::JSON;
use Role::Tiny;
use JSON 'encode_json';

requires qw( data );

around data => sub  {
  my $orig = shift;
  my $self = shift;

  return encode_json( $self->$orig() );
};

6. Compositional safety

Roles attempt to guarantee compositional safety. So, if two roles have the same method defined and you try to consume them in the same class, you will get an error message.

 Due to method name conflicts in roles ....

Just remember that in order to trigger the error message you need to consume all the roles at once:

# good
package Foo;
use lib 'lib';
use Role::Tiny::With;
with  'Role::XML', 'Role::JSON';

# bad second method is ignored
package Foo;
use lib 'lib';
use Role::Tiny::With;
with  'Role::XML'; 
with  'Role::JSON';

7. How to fix method collision

implement the methods yourself in your class, thus causing the corresponding role methods to be ignored
For Moose use the excludes key word

package Role::JSON;
use Moose::Role;

sub serialize { ... }

package Role::XML;
use Moose::Role;

sub serialize { ... }

package Foo;
use Moose;
with Role::Serializable::JSON,
     Role::Serializable::XML => { excludes => 'serialize' };

For Role::Tiny use namespace::clean

package Role::XML;

use Role::Tiny;

sub serialize { my $self = shift; print 'test'  };
# serialize() will not be imported in the consuming class
use namespace::clean;

1;

8. Bibliography