#!/usr/bin/perl

use 5.010;
use strict;
use warnings;
use utf8;

use Getopt::Long;
use Pod::Usage;
use Linux::Smaps;
use Storable qw(freeze thaw);
use List::Util qw(sum);

my $smaps = Linux::Smaps->new;

exit main();

sub main {
    my ($help, $help2);
    my $test_no = 1;
    my $do_all = 0;
    GetOptions(
        'help|h' => \$help,
        'tips' => \$help2,
        'test=s' => \$test_no,
        'all'    => \$do_all,
    ) or pod2usage;
    pod2usage({-verbose => 99, -sections => 'NAME|SYNOPSIS|DESCRIPTION'}) if $help;
    pod2usage({-verbose => 99, -sections => 'TIPS FOR LESS MEMORY FOOTPRINT|SEE ALSO'}) if $help2;

    if ($do_all && ($test_no == 1)) {
        system($^X, (map {'-I' . $_} @INC), $0, '--help');
    }

    say '-'x80;

    my $no_more_tests;

    if ($test_no == 1) {
        say 'Perl execution of this script';
        eval q{
            say 'just do nothing....';
        };
        die $@ if $@;
        # ~9M
    }
    elsif ($test_no == 2) {
        say 'create 100mio character big scalar using 100 character chunks';
        my $t;

        my $test_case = '$t .= "a"x100 for 1..1_000_000;';
        say_code($test_case);        
        eval $test_case.q{
            say 'length($t): '.length($t);
            say_memory();
        };
        die $@ if $@;
        # ~117M
    }
    elsif ($test_no == 3) {
        say 'create 100mio character big scalar using "x" constructor';
        my $t;

        my $test_case = '$t .= "." x 100_000_000;';
        say_code($test_case);        
        eval $test_case.q{
            say 'length($t): '.length($t);
            say_memory();
        };
        die $@ if $@;
        # ~218M
    }
    elsif ($test_no == 4) {
        say 'create array with 1_000 scalars, each little less then 128kB';
        my @ta;

        my $test_case = 'push(@ta, "." x (128*1024-14)) for (1..1_000);';
        say_code($test_case);        
        eval $test_case.q{
            say 'scalar(@ta): '.scalar(@ta);
            say_memory();
        };
        die $@ if $@;
        # ~134M
    }
    elsif ($test_no == 5) {
        say 'create array with 1_000 scalars, each 128kB big';
        my @ta;

        my $test_case = 'push(@ta, "." x (128*1024-13)) for (1..1_000);';
        say_code($test_case);        
        eval $test_case.q{
            say 'scalar(@ta): '.scalar(@ta);
            say_memory();
        };
        die $@ if $@;
        # ~138M   →   ~9M
    }
    elsif ($test_no == 6) {
        say 'create hash with 1_000_000 scalars each 100 characters big';
        my %th;
        my $key_id = 1;

        my $test_case = '$th{"k".$key_id++} = "x".100 for (1..1_000_000);';
        say_code($test_case);        
        eval $test_case.q{
            say 'scalar(keys %th): '.scalar(keys %th);
            say_memory();
        };
        die $@ if $@;
        # ~108M
    }
    elsif ($test_no == 7) {
        say 'create 2x hashes with 1_000_000 scalars 100 characters big';
        my (%th, %th2);
        my $key_id = 1_000_000;

        my $test_case = 'for (1..1_000_000) { $th{"k".$key_id++} = "x".100; $th2{"k".$key_id++} = "x".100  }';
        say_code($test_case);        
        eval $test_case.q{
            say 'scalar(keys %th): '.scalar(keys %th);
            say 'scalar(keys %th2): '.scalar(keys %th2);
            say_memory();
        };
        die $@ if $@;
        # ~209M
    }
    elsif ($test_no == 8) {
        say 'create 2x hashes with 1_000_000 scalars 100 characters big, but with same set of keys';
        say '(Perl hash keys have shared storage in Perl, that is why less memory is used)';
        my (%th, %th2);
        my $key_id = 1_000_000;

        my $test_case = 'for (1..1_000_000) { $th{"k".$key_id} = "x".100; $th2{"k".$key_id++} = "x".100  }';
        say_code($test_case);        
        eval $test_case.q{
            say 'scalar(keys %th): '.scalar(keys %th);
            say 'scalar(keys %th2): '.scalar(keys %th2);
            say_memory();
        };
        die $@ if $@;
        # ~166M
    }
    elsif ($test_no == 9) {
        say 'create 2x hashes with 1_000_000 scalars (via two 1_000 loops) 100 characters big';
        my (%th, %th2);
        my $key_id = 1_000_000;

        my $test_case = 'for (1..1_000) { for (1..1_000) { $th{"k".$key_id++} = "x".100; $th2{"k".$key_id++} = "x".100  } }';
        say_code($test_case);        
        eval $test_case.q{
            say 'scalar(keys %th): '.scalar(keys %th);
            say 'scalar(keys %th2): '.scalar(keys %th2);
            say_memory();
        };
        die $@ if $@;
        # ~209M
    }
    elsif ($test_no == 10) {
        say 'create array with serialized 2x hashes with 1_000_000 scalars (via two 1_000 loops) 100 characters big';
        say '(serialization functions are also doing compression)';
        my (@ta, %th, %th2);
        my $key_id = 1_000_000;

        my $test_case = 'for (1..1_000) { for (1..1_000) {  $th{"k".$key_id++} = "x".100; $th2{"k".$key_id++} = "x".100 }; push(@ta, freeze(\%th), freeze(\%th2)); (%th, %th2) = (); }';
        say_code($test_case);        
        eval $test_case.q{
            say 'scalar(keys %th): '.scalar(keys %th);
            say 'scalar(keys %th2): '.scalar(keys %th2);
            say 'scalar(@ta): '.scalar(@ta);
            say 'length($ta[-1]): '.length($ta[-1]);
            say 'thaw($ta[-1]): '.thaw($ta[-1]);
            say 'sum(map {scalar(keys(%{thaw($_)}))} @ta): '.sum(map {scalar(keys(%{thaw($_)}))} @ta);
            say_memory();
        };
        die $@ if $@;
        # ~43M   →   ~41M
    }
    elsif ($test_no == 11) {
        say 'create array with serialized 2x hashes with 1_000_000 scalars (via two 500x2000 loop) 100 random characters big';
        say '(random characters there so that the serialization is not able to compress this data)';
        my (@ta, %th, %th2);
        my $key_id = 1_000_000;

        my $test_case = 'for (1..500) { for (1..2_000) { $key_id++; $th{"k".$key_id} .= chr(rand(256)) for 1..100; $th2{"k".$key_id} .= chr(rand(256)) for 1..100 }; push(@ta, freeze(\%th), freeze(\%th2)); (%th, %th2) = (); }';
        say_code($test_case);        
        eval $test_case.q{
            say 'scalar(keys %th): '.scalar(keys %th);
            say 'scalar(keys %th2): '.scalar(keys %th2);
            say 'scalar(@ta): '.scalar(@ta);
            say 'length($ta[-1]): '.length($ta[-1]);
            say 'thaw($ta[-1]): '.thaw($ta[-1]);
            say 'sum(map {scalar(keys(%{thaw($_)}))} @ta): '.sum(map {scalar(keys(%{thaw($_)}))} @ta);
            say_memory();
        };
        die $@ if $@;
        # ~229M   →   ~10M
    }
    else {
        $no_more_tests = 1;
    }

    unless ($no_more_tests) {
        say 'done test case '.$test_no;
        say_memory();
    }

    if ($do_all) {
        if ($no_more_tests) {
            say '';
            system($^X, (map {'-I' . $_} @INC), $0, '--tips');
            say '-'x80;
            return 0;
        }
        else {
            $test_no++;
            exec($^X, (map {'-I' . $_} @INC), $0, '--all', '--test', $test_no);
        }
    }

    say '-'x80;
    say 'sleeping "forever" so that you can double-check via `top`';
    system('ps awux | grep -E "(^USER|'.$0.')"');
    sleep(60*60);

    return 0;
}

sub say_code {
    my ($code) = @_;
    say 'code: '.$code;
}

sub say_memory {
    say 'allocated memory size: '.format_size($smaps->update->size);
}

sub format_size {
    my ($mem_size) = @_;
    
    if ($mem_size < 1024) {
        return sprintf('%.2fK', $mem_size);
    }
    elsif ($mem_size < 1024*1024) {
        return sprintf('%.2fM', $mem_size / 1024);
    }
    else {
        return sprintf('%.2fG', $mem_size / (1024*1024));
    }
}

=encoding utf8

=head1 NAME

mem-free-release-test.pl - example script to test and demonstrate how and when memory is being released back to the system

=head1 SYNOPSIS

    ./mem-free-release-test.pl --all
    ./mem-free-release-test.pl --test 10

        --test X        execute one test only, default 1
        --all           execute all X+ tests

=head1 DESCRIPTION

This script includes 1 to X memory allocation test cases. These cases can be executed per one using C<--test X>
or all sequentially using C<--all> switches.

Each test will perform a code inside a block and print out memory usage within
and after leaving the block scope → when the local variable memory is
garbage collected and freed.

Cases where the allocated memory inside and outside the block are (nearly) the same are not memory leaks, memory is returned
back for further usage, but only inside that given process. Cases where the allocated memory decreases outside the block
means that the memory was freed and returned back to the operating system. See below link to stackoverflow question 2215259
about malloc() and returning memory back to the OS.

(L<Will malloc implementations return free-ed memory back to the system?|https://stackoverflow.com/questions/2215259>)

Long story short → M_TRIM_THRESHOLD in Linux is by default set to 128K, only memory blocks of 128K size are returned back to the OS.

This does not help a lot with huge number of small data strictures arrays-of-hashes-of-hashes, unless a small trick is used.

=head1 TIPS FOR LESS MEMORY FOOTPRINT

=over 4

=item read the B<Rules Of Optimization Club>

L<http://wiki.c2.com/?RulesOfOptimizationClub>

=item just add more memory

Unless that code is taking gigabytes of memory, don't worry, memory is cheap and plentiful these days, or?

=item have a good coffee and good monitoring at your side

Chart the (virtual) server memory free over long period to spot extremes and to see effects
of your memory optimisations.

=item terminate and restart

The simplest way to release memory is to terminate the process, possibly with status saved, and then start it again right away.
SystemD and daemontools understands this concept and can be configured for continuous restarts.

=item work in chunks if possible

Query database using cursors, 1_000 rows at a time, process it and then do the next.

If you need to load 1_000_000 data hashes, split them into chunks that can be serialized.
With or without compression freezed data structures takes much less memory. Memory of
those block, when greater then 128k, will be returned back to the system.

=item fork before memory intensive operation 

If the processed data just needs to be saved to disk, or transferred, or post processed once all in-memory
you can fork off a child process to do this job. Will not only make that tasks run in
parallel, but also all the extra memory allocated inside the child process will be cleared
by process termination.

=back

=head1 SEE ALSO

L<Linux::Smaps - a Perl interface to /proc/PID/smaps|https://metacpan.org/pod/Linux::Smaps>

L<Sereal - Fast, compact, powerful binary (de-)serialization|https://metacpan.org/pod/Sereal>

L<Parallel::ForkManager - A simple parallel processing fork manager|https://metacpan.org/pod/Parallel::ForkManager>

=cut
