view release on metacpan or  search on metacpan

lib/Sidef.pm  view on Meta::CPAN

            return $self->{dbm_driver};
        }

        if (eval { require DB_File; 1 }) {
            return ($self->{dbm_driver} = 'bdbm');
        }

        if (eval { require GDBM_File; 1 }) {
            return ($self->{dbm_driver} = 'gdbm');
        }

        warn "No supported database driver was found...\n";
        warn "Please install DB_File or GDBM_File in order to use this functionality.\n";
        return;
    }

    sub _init_db {
        my ($self, $hash, $db_file) = @_;
        dbmopen(%$hash, $db_file, 0640);
    }

    sub _init_time_db {
        my ($self, $lang) = @_;

        if (not exists $self->{$lang}{_time_hash}) {
            $self->{$lang}{_time_hash} = {};
            $self->_init_db($self->{$lang}{_time_hash}, $self->{$lang}{time_db});

            if (not exists $self->{$lang}{_time_hash}{sanitized}) {
                $self->{$lang}{_time_hash}{sanitized} = time;
            }
        }
    }

    sub _init_code_db {
        my ($self, $lang) = @_;

        if (not exists $self->{$lang}{_code_hash}) {
            $self->{$lang}{_code_hash} = {};
            $self->_init_db($self->{$lang}{_code_hash}, $self->{$lang}{code_db});
        }
    }

    sub dbm_lookup {
        my ($self, $lang, $md5) = @_;

        $self->_init_time_db($lang)
          if not exists($self->{$lang}{_time_hash});

        if (exists($self->{$lang}{_time_hash}{$md5})) {

            $self->_init_code_db($lang)
              if not exists($self->{$lang}{_code_hash});

            if (time - $self->{$lang}{_time_hash}{$md5} >= UPDATE_SEC) {
                $self->{$lang}{_time_hash}{$md5} = time;
            }

            my $compressed_code = $self->{$lang}{_code_hash}{$md5};

            state $_x = require IO::Uncompress::RawInflate;
            IO::Uncompress::RawInflate::rawinflate(\$compressed_code => \my $decompressed_code)
              or die "rawinflate failed: $IO::Uncompress::RawInflate::RawInflateError";

            return Encode::decode_utf8($decompressed_code);
        }

        return;
    }

    sub dbm_store {
        my ($self, $lang, $md5, $code) = @_;

        $self->_init_code_db($lang)
          if not exists($self->{$lang}{_code_hash});

        # Sanitize the database, by removing old entries
        if (time - $self->{$lang}{_time_hash}{sanitized} >= SANITIZE_SEC) {

            $self->{$lang}{_time_hash}{sanitized} = time;

            my @delete_keys;
            while (my ($key, $value) = each %{$self->{$lang}{_time_hash}}) {
                if (time - $value >= DELETE_SEC) {
                    push @delete_keys, $key;
                }
            }

            if (@delete_keys) {
                delete @{$self->{$lang}{_time_hash}}{@delete_keys};
                delete @{$self->{$lang}{_code_hash}}{@delete_keys};
            }
        }

        state $_x = require IO::Compress::RawDeflate;
        IO::Compress::RawDeflate::rawdeflate(\$code => \my $compressed_code)
          or die "rawdeflate failed: $IO::Compress::RawDeflate::RawDeflateError";

        $self->{$lang}{_time_hash}{$md5} = time;
        $self->{$lang}{_code_hash}{$md5} = $compressed_code;
    }

    sub compile_code {
        my ($self, $code, $lang) = @_;

        $lang //= 'Sidef';

        if (
            $self->{opt}{s}
            ##and length($$code) > 1024
            and $self->has_dbm_driver
          ) {

            my $db_dir = ($self->{$lang}{db_dir} //= File::Spec->catdir($self->get_sidef_vdir(), $lang));

            if (not -e $db_dir) {
                require File::Path;
                File::Path::make_path($db_dir);
            }

            state $_x = do {
                require Encode;
                require Digest::MD5;
            };

            my $md5 = Digest::MD5::md5_hex(Encode::encode_utf8($code));

            $self->{$lang}{time_db} //= File::Spec->catfile($db_dir, 'Sidef_Time_' . $self->{dbm_driver} . '.db');
            $self->{$lang}{code_db} //= File::Spec->catfile($db_dir, 'Sidef_Code_' . $self->{dbm_driver} . '.db');

            if (defined(my $cached_code = $self->dbm_lookup($lang, $md5))) {
                return $cached_code;
            }

            my $evals_num = keys(%EVALS);

            local $self->{environment_name} = 'Sidef::Runtime' . $md5;
            my $deparsed = $self->compile_ast($self->parse_code($code), $lang);

            if ($lang eq 'Perl') {
                $deparsed = "package $self->{environment_name} {$deparsed}\n";
            }

            # Don't store code that contains eval()
            if (keys(%EVALS) == $evals_num) {
                $self->dbm_store($lang, $md5, Encode::encode_utf8($deparsed));
            }

            return $deparsed;
        }

        state $count = 0;
        local $self->{environment_name} = 'Sidef::Runtime' . (CORE::abs($count++) || '');

        my $deparsed = $self->compile_ast($self->parse_code($code), $lang);