view release on metacpan or  search on metacpan

lib/Container/Builder.pm  view on Meta::CPAN

					$tar_file = $tar_builder->extract_wildcard_files($tar, $_);
				} else {
					$tar_file = $tar_builder->extract_file($tar, $_);
				}
				$result_tar .= $tar_file;
			}
			$result_tar .= "\x00" x 1024; # two empty blocks
			push @layers, Container::Builder::Layer::Tar->new(comment => "custom $package_name", data => $result_tar);
		} else {
			die "Did not find deb package with name $package_name\n";
		}
	}

	# Create a layer that has one file
	method add_file($file_on_disk, $location_in_ctr, $mode, $user, $group) {
		die "Cannot read file at $file_on_disk\n" if !-r $file_on_disk;
		push @layers, Container::Builder::Layer::SingleFile->new(comment => $location_in_ctr, file => $file_on_disk, dest => $location_in_ctr, mode => $mode, user => $user, group => $group);
	}

	method add_file_from_string($data, $location_in_ctr, $mode, $user, $group, $compressed = 0) {
		push @layers, Container::Builder::Layer::SingleFile->new(comment => $location_in_ctr, data => $data, dest => $location_in_ctr, mode => $mode, user => $user, group => $group, compress => $compressed);
	}

	method copy($local_dirpath, $location_in_ctr, $mode, $user, $group) {
		if(!-d $local_dirpath) {
			die "Container::Builder::copy() only supports directories. Use add_file() or add_file_from_string() if you need to copy one file\n";
		}
		$local_dirpath .= (substr($local_dirpath, -1) eq '/' ? '' : '/');
		my $local_basename = basename($local_dirpath);
		my $prefix_path = $location_in_ctr;
		if(substr($location_in_ctr, -1) eq '/') {# say "ctr location ends with /, so that means our folder $local_basename becomes a subfolder";
			$prefix_path .= $local_basename . '/';
		} else {
			my $remote_basename = basename($location_in_ctr);
			#say "ctr location doesnt end with /, so that means our folder $local_basename gets renamed to $remote_basename";
			$prefix_path .= '/';
		}

		my $iterator = Path::Class::Iterator->new(root => $local_dirpath, follow_symlinks => 0, follow_hidden => 0);
		my $tar = Container::Builder::Tar->new();
		$tar->add_dir($prefix_path, $mode, $user, $group);
		until($iterator->done) {
			my $item = $iterator->next;
			if($item->is_dir()) {
				my $remote_dir = $prefix_path . substr($item, length($local_dirpath));
				my $mode = (stat($item))[2] & 07777;
				$tar->add_dir($remote_dir, $mode, $user, $group);
			} else {
				my $remote_file = $prefix_path . substr($item, length($local_dirpath));
				my $mode = (stat($item))[2] & 07777;
				local $/ = undef;
				open(my $file, '<', $item) or die "cannot open file $item for reading\n";
				my $data = <$file>;
				$tar->add_file($remote_file, $data, $mode, $user, $group);
			}
		}
		push @layers, Container::Builder::Layer::Tar->new(comment => $local_dirpath, data => $tar->get_tar());
	}

	# Create a layer that creates a directory in the container
	method create_directory($path, $mode, $uid, $gid) {
		my %dir = (path => $path, mode => $mode, uid => $uid, gid => $gid);
		push @dirs, \%dir;
	}

	# Create a layer that adds a user to the container
	# this is a wrapper to make a change to passwd?
	method add_user($name, $uid, $main_gid, $shell, $homedir) {
		$name =~ s/[^a-z]//ig;
		$uid =~ s/[^\d]//g;
		$main_gid =~ s/[^\d]//g;
		die "Conflicting user" if grep { $_->{name} eq $name || $_->{uid} == $uid || $_->{gid} == $main_gid } @users;
		my %new_user = (name => $name, uid => $uid, gid => $main_gid, shell => $shell, homedir => $homedir);
		push @users, \%new_user;
	}

	# Create a layer that adds a group to the container
	method add_group($name, $gid) {
		$name =~ s/[^a-z]//ig;
		$gid =~ s/[^\d]//g;
		die "Conflicting with existing group\n" if grep {$_->{name} eq $name || $_->{gid} == $gid } @groups;
		my %new_group = (name => $name, gid => $gid);
		push @groups, \%new_group;
	}

	# similar to USER in Dockerfile
	method runas_user($user) {
		my $found_user = 0;
		foreach(@users) {
			$found_user = 1 if $_->{name} eq $user;
		}
		die "Cannot set the USER to $user if it's not part of the users in the container\n" if !$found_user;
		$runas = $user;
	}

	# Sets an environment variable, similar to ENV in Dockerfile
	method set_env($key, $value) {
		# TODO: probably needs some escaping for nasty value's or values with an '=', ...
		$env{$key} = $value;
	}

	# Set entrypoint
	method set_entry(@command_str) {
		die "Entrypoint/Command list is empty\n" if !@command_str;
		push @entry, shift(@command_str);
		push @cmd, @command_str;
	}

	method set_work_dir($workdirectory) {
		$work_dir = $workdirectory;
	}

	method build {
		my $filename_result = '';
		my $tag_name = '';
		if(@_ == 4) {
			if($_[0] eq 'filename_result' && $_[2] eq 'tag_name') {
				$filename_result = $_[1];
				$tag_name = $_[3];
			} elsif($_[0] eq 'tag_name' && $_[2] eq 'filename_result') {
				$tag_name = $_[1];
				$filename_result = $_[3];
			} else {
				return -1;
			}
		} elsif(@_ == 3) {
				return -1;
		} elsif(@_ == 2) {
			if($_[0] eq 'filename_result') {
				$filename_result = $_[1];
			} elsif($_[0] eq 'tag_name') {
				$tag_name = $_[1];
			} else {
				$filename_result = $_[0];
				$tag_name = $_[1];
			}
		} elsif(@_ == 1) { # Backwards compatibility
			$filename_result = $_[0];
		}

		# Make 1 layer with all the base files
		my $tar = Container::Builder::Tar->new();

			foreach(@dirs) {
				$tar->add_dir($_->{path}, $_->{mode}, $_->{uid}, $_->{gid});
			}

			# Generate /etc/group file
			my $etcgroup = '';
			map { $etcgroup .= $_->{name} . ':x:' . $_->{gid} . ':' . $/ } @groups;
			$tar->add_file('/etc/group', $etcgroup, 0644, 0, 0);

			# Generate /etc/passwd file
			my $etcpasswd = '';
			# example line: root:x:0:0:root:/root:/bin/bash
			map { $etcpasswd .= $_->{name} . ':x:' . $_->{uid} . ':' . $_->{gid} . ':' . $_->{name} . ':' . $_->{homedir} . ':' . $_->{shell} . $/ } @users;
			$tar->add_file('/etc/passwd', $etcpasswd, 0644, 0, 0);
	
		my $tar_content = $tar->get_tar();
		unshift @layers, Container::Builder::Layer::Tar->new(comment => 'Base files', data => $tar_content);

		$tar = Container::Builder::Tar->new();
		$tar->add_dir('blobs/', 0755, 0, 0);
		$tar->add_dir('blobs/sha256/', 0755, 0, 0);
		# Add all layers
		foreach(@layers) {
			my $data = $_->generate_artifact();
			my $digest = $_->get_digest();
			$tar->add_file('blobs/sha256/' . $digest, $data, 0644, 0, 0);
		}

		# We need to generate our artifacts before we can call the Config, because we need the sizes and digests of the layers...
		my $config = Container::Builder::Config->new();
		my @envarr = map { $_ . '=' . $env{$_} } keys(%env);
		my $config_json = $config->generate_config($runas, \@envarr, \@entry, \@cmd, $work_dir, \@layers);
		$tar->add_file('blobs/sha256/' . $config->get_digest(), $config_json, 0644, 0, 0);
		$ctr_digest = $config->get_digest();

		my $manifest = Container::Builder::Manifest->new();
		my $manifest_json = $manifest->generate_manifest($config->get_digest(), $config->get_size(), \@layers);
		$tar->add_file('blobs/sha256/' . $manifest->get_digest(), $manifest_json, 0644, 0, 0);

		my $oci_layout = '{"imageLayoutVersion": "1.0.0"}';
		$tar->add_file('oci-layout', '{"imageLayoutVersion": "1.0.0"}', 0644, 0, 0);
		my $index = Container::Builder::Index->new();
		$tar->add_file('index.json', $index->generate_index($manifest->get_digest(), $manifest->get_size(), $tag_name), 0644, 0, 0);

		if($filename_result) {
			open(my $o, '>', $filename_result) or die "cannot open $filename_result\n";
			print $o $tar->get_tar();
			close($o);
		} else {
			return $tar->get_tar();
		}
	}

	method get_digest() {
		die "Run build() first" if ! $ctr_digest;
		$ctr_digest;
	}
}

1;
__END__

=encoding utf-8

=pod

=head1 NAME

Container::Builder - Build Container archives.

=head1 SYNOPSIS

  # See also the examples/ folder of this module.

lib/Container/Builder.pm  view on Meta::CPAN

=head1 DESCRIPTION

Container::Builder builds a TAR archive that can be imported into Podman or Docker. It's main use is to craft specific, small containers based on Debian package (.deb) files. The type of functions to extend are similar to those that you can find in a...

We use a Build pattern to build the archive. Most functions return quickly, and only the C<build()> function actually creates all the layers of the container and writes the result to disk.

Look into the C<examples/> folder for some examples to make working Perl (Dancer2) images.

B<Note>: This module is not production-ready! It's still in early stages of development and maturity.

=head1 METHODS

=over 1

=item new(debian_pkg_hostname => 'mirror.as35701.net', [compress_deb_tar => 1], [os_version => 'bookworm'], [cache_folder => 'artifacts/'], [enable_packages_cache => 0], [packages_file => 'Packages'])

I<the square brackets signify that the parameter is optional, not an array ref>

Create a Container::Builder object. Only the C<debian_pkg_hostname> parameter is required so you can pick a Debian mirror close to the geographical region from where the code is running. See L<https://www.debian.org/mirror/list>.

C<compress_deb_tar> compresses the debian TAR archives with Gzip before storing. You're trading build speeds in for less disk space.

C<os_version> controls which Debian Packages will be used to find the packages on the mirror.

When C<cache_folder> is defined, the folder will be used to store the downloaded deb packages and it will be used in subsequent runs as a cache so we don't retrieve it from the debian mirror every single time.

C<enable_packages_cache> will look for a Packages file defined by C<packages_file> option. If it doesn't exist, it will be downloaded from the Debian mirror. If it does exist, it will be read from disk instead of getting a fresh copy.

=item add_deb_package('libperl5.36')

Add a Debian package to the container. The C<data.tar> file inside the Debian package file (C<.deb>) will be stored as a layer in the resulting container. 

=item add_deb_package_from_file($filepath_deb)

Add a Debian package file to the container. The C<data.tar> file inside the Debian package file (C<.deb>) will be stored as a layer in the resulting container. 

=item extract_from_deb($package_name, $files_to_extract)

Extract certain files from the Debian package before storing as a layer. C<$package_name> is the name of the Debian package, C<$files_to_extract> is an array ref containing a list of files to extract. Rudimentary support for globs/wildcards (only use...

I<This is an experimental method.>

=item add_file($file_on_disk, $location_in_ctr, $mode, $user, $group)

Adds the local file C<$file_on_disk> inside the container at location C<$location_in_ctr> with the specified C<$mode>, C<$user> and C<$group>.

=item add_file_from_string($data, $location_in_ctr, $mode, $user, $group, [$compressed])

Adds the data in the scalar C<$data> to the container at location C<$location_in_ctr> with the specified C<$mode>, C<$user> and C<$group>.

C<$compressed> is a boolean to determine if the image layer will be compressed.

=item copy($local_dirpath, $location_in_ctr, $mode, $user, $group)

Recursively copy the C<$local_dirpath> directory into a layer of the container. The resulting path inside the container is defined by C<$location_in_ctr>. C<$mode> controls the directory permission of C<$location_in_ctr> only. Inner directories will ...

If C<$location_in_ctr> has a slash at the end, the last directory of C<$local_dirpath> will become a subdirectory of the path C<$location_in_ctr>. Otherwise, the last directory of C<$local_dirpath> will be renamed to the last directory of C<$location...

For example C<copy('lib/', '/app/')> will create C</app/lib/> but C<copy('lib/', '/app')> will put all put the files and directories directly inside C</app>, there will be no C<lib> directory.

=item create_directory($path, $mode, $uid, $gid)

Create an empty directory at C<$path> inside the container with the specified C<$mode>, C<$user> and C<$group>.

=item add_user($name, $uid, $main_gid, $shell, $homedir)

Add a user to the container. This puts the user inside the C</etc/passwd> file.

=item add_group($name, $gid)

Add a group to the container. This puts the group inside the C</etc/group> file.

=item runas_user($user)

Specify the user to run the entrypoint as.

=item set_env($key, $value)

Add a environment variable to the container definition.

=item set_entry(@command_str)

Set the default entrypoint of the container.

=item set_work_dir($workdirectory)

Set the default working directory of the container.

=item build()

=item build('mycontainer.tar')

=item build(filename_result => 'mycontainer.tar')

=item build('mycontainer.tar', 'localhost/ctr:latest')

=item build(filename_result => 'mycontainer.tar', tag_name => 'localhost/ctr:latest')

Build the container and write the result to the filepath specified. C<tag_name> sets an annotation in the Index so that other tooling knows how to tag the image container upon loading.

=item get_digest()

Returns the digest of the embedded config file in the archive. This digest is used by tools such as podman as a unique ID to your container.

=item get_layers()

Returns a list of C<Container::Builder::Layer> objects as currently added to the Builder. 

Note: During build() extra layers can be added in the front or at the end of this list.

=back

=head1 AUTHOR

Adriaan Dens E<lt>adri@cpan.orgE<gt>

=head1 COPYRIGHT

Copyright 2026- Adriaan Dens

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=head1 SEE ALSO

L<Google distroless|https://github.com/GoogleContainerTools/distroless> containers are the main inspiration for creating this module. The idea of creating minimal containers based on Debian packages comes from the Bazel build code in the linked repos...