view release on metacpan or  search on metacpan

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

		die "Unable to read $filepath_deb\n" if !-r $filepath_deb;
		push @layers, Container::Builder::Layer::DebianPackageFile->new(comment => $filepath_deb, file => $filepath_deb, compress => $compress_deb_tar);
	}

	method extract_from_deb($package_name, $files_to_extract) {
		my $deb_archive = $self->_get_deb_package($package_name);
		if($deb_archive) {
			# Read the tar -> with our own class because Archive::Tar doesn't read from a string...
			my $deb = Container::Builder::Layer::DebianPackageFile->new(comment => $package_name, data => $deb_archive, compress => $compress_deb_tar);
			my $tar = $deb->generate_artifact();
			my $tar_builder = Container::Builder::Tar->new();
			my $result_tar = '';
			foreach(@$files_to_extract) {
				my $tar_file = '';
				if($_ =~ /\*$/) {
					$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) {
		push @layers, Container::Builder::Layer::SingleFile->new(comment => $location_in_ctr, data => $data, dest => $location_in_ctr, mode => $mode, user => $user, group => $group);
	}

	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;